git.iko.soy/elk
on master help sign in
Merge install logic into Install.hs and use Solver.initEnv
42b8ce2Evan Czaplicki
builder/src/Elm/Install.hsdeleted−448
compare with master
unifiedsplit
@@ -1,448 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Install
3− ( install
4− )
5− where
6−
7−
8−import Control.Monad (filterM, foldM, forM, msum, void)
9−import Control.Monad.Except (catchError, lift, liftIO)
10−import Data.Map ((!))
11−import qualified Data.Map as Map
12−import qualified Data.Map.Merge.Lazy as Map
13−
14−import qualified Elm.Package as Pkg
15−
16−import qualified Deps.Cache as Cache
17−import Deps.Explorer (Explorer)
18−import qualified Deps.Explorer as Explorer
19−import qualified Deps.Verify as Verify
20−import qualified Deps.Solver as Solver
21−import qualified Elm.Constraint as C
22−import qualified Elm.Project.Json as Project
23−import qualified Elm.Project.Root as Root
24−import qualified Elm.Version as V
25−import Reporting.Doc ((<>), (<+>))
26−import qualified Reporting.Doc as D
27−import qualified Reporting.Exit as Exit
28−import qualified Reporting.Exit.Install as E
29−import qualified Reporting.Task as Task
30−
31−
32−
33−-- INSTALL
34−
35−
36−install :: Pkg.Name -> Task.Task ()
37−install pkg =
38− do (root, oldProject) <- Root.unsafeGet
39− registry <- Cache.optionalUpdate
40−
41− case oldProject of
42− Project.App info ->
43− do changes <- makeAppPlan registry pkg info
44− attemptElmJsonChange root oldProject V.toChars changes
45−
46− Project.Pkg info ->
47− do changes <- makePkgPlan registry pkg info
48− attemptElmJsonChange root oldProject C.toChars changes
49−
50−
51−attemptElmJsonChange :: FilePath -> Project.Project -> (a -> String) -> Changes a -> Task.Task ()
52−attemptElmJsonChange root oldProject toChars changes =
53− let
54− attempt newProject question =
55− do approved <- Task.getApproval question
56− if approved
57− then upgrade newProject `catchError` revert
58− else liftIO $ putStrLn "Okay, I did not change anything!"
59−
60− upgrade newProject =
61− do liftIO $ Project.write root newProject
62− void $ Verify.verify root newProject
63−
64− revert err =
65− do liftIO $ Project.write root oldProject
66− Task.throw err
67− in
68− case changes of
69− AlreadyInstalled ->
70− do liftIO $ putStrLn "It is already installed!"
71−
72− PromoteTrans newProject ->
73− attempt newProject $
74− D.vcat
75− [ D.fillSep
76− ["I","found","it","in","your","elm.json","file,"
77− ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."
78− ]
79− , D.fillSep
80− ["Should","I","move","it","into",D.green "\"direct\""
81− ,"dependencies","for","more","general","use?","[Y/n]: "
82− ]
83− ]
84−
85− PromoteTest newProject ->
86− attempt newProject $
87− D.vcat
88− [ D.fillSep
89− ["I","found","it","in","your","elm.json","file,"
90− ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."
91− ]
92− , D.fillSep
93− ["Should","I","move","it","into",D.green "\"dependencies\""
94− ,"for","more","general","use?","[Y/n]: "
95− ]
96− ]
97−
98− Changes changeDict newProject ->
99− let
100− widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict
101− changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict
102− in
103− attempt newProject $ D.vcat $
104− [ "Here is my plan:"
105− , viewChangeDocs changeDocs
106− , ""
107− , "Would you like me to update your elm.json accordingly? [Y/n]: "
108− ]
109−
110−
111−
112−-- MAKE PLANS
113−
114−
115−data Changes vsn
116− = AlreadyInstalled
117− | PromoteTest Project.Project
118− | PromoteTrans Project.Project
119− | Changes (Map.Map Pkg.Name (Change vsn)) Project.Project
120−
121−
122−makeAppPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task (Changes V.Version)
123−makeAppPlan registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
124− if Map.member pkg depsDirect then
125− return AlreadyInstalled
126− else
127− do (AppAnswer old new newInfo) <- toAppAnswer registry pkg info
128−
129− return $
130− if Map.member pkg depsTrans then
131− PromoteTrans (Project.App newInfo)
132−
133− else if Map.member pkg testDirect || Map.member pkg testTrans then
134− PromoteTest (Project.App newInfo)
135−
136− else
137− Changes (detectChanges old new) (Project.App newInfo)
138−
139−
140−makePkgPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Changes C.Constraint)
141−makePkgPlan registry pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) =
142− if Map.member pkg deps then
143− return AlreadyInstalled
144− else
145− case Map.lookup pkg test of
146− Just con ->
147− return $ PromoteTest $ Project.Pkg $
148− info
149− { Project._pkg_deps = Map.insert pkg con deps
150− , Project._pkg_test_deps = Map.delete pkg test
151− }
152−
153− Nothing ->
154− do changes <- addToPkg registry pkg info
155− let news = Map.mapMaybe keepNew changes
156− return $ Changes changes $ Project.Pkg $
157− info
158− { Project._pkg_deps = addNews (Just pkg) news deps
159− , Project._pkg_test_deps = addNews Nothing news test
160− }
161−
162−
163−addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a
164−addNews pkg new old =
165− Map.merge
166− Map.preserveMissing
167− (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))
168− (Map.zipWithMatched (\_ _ n -> n))
169− old
170− new
171−
172−
173−
174−-- CHANGES
175−
176−
177−data Change a
178− = Insert a
179− | Change a a
180− | Remove a
181−
182−
183−detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)
184−detectChanges old new =
185− Map.merge
186− (Map.mapMissing (\_ v -> Remove v))
187− (Map.mapMissing (\_ v -> Insert v))
188− (Map.zipWithMaybeMatched keepChange)
189− old
190− new
191−
192−
193−keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
194−keepChange _ old new =
195− if old == new then
196− Nothing
197− else
198− Just (Change old new)
199−
200−
201−keepNew :: Change a -> Maybe a
202−keepNew change =
203− case change of
204− Insert a ->
205− Just a
206−
207− Change _ a ->
208− Just a
209−
210− Remove _ ->
211− Nothing
212−
213−
214−
215−-- ADD TO APP
216−
217−
218−data AppAnswer =
219− AppAnswer
220− { _old :: Map.Map Pkg.Name V.Version
221− , _new :: Map.Map Pkg.Name V.Version
222− , _info :: Project.AppInfo
223− }
224−
225−
226−toAppAnswer :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task AppAnswer
227−toAppAnswer registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
228− Explorer.run registry $
229− do Explorer.exists pkg
230− result <- Solver.run (toAppAnswerHelp pkg info)
231− case result of
232− Just answer ->
233− return answer
234−
235− Nothing ->
236− do badNames <-
237− filterM isBadElm $
238− pkg : Map.keys depsDirect
239− ++ Map.keys depsTrans
240− ++ Map.keys testDirect
241− ++ Map.keys testTrans
242− lift $ Task.throw (Exit.Install (E.NoSolution badNames))
243−
244−
245−toAppAnswerHelp :: Pkg.Name -> Project.AppInfo -> Solver.Solver AppAnswer
246−toAppAnswerHelp pkg (Project.AppInfo elm srcDirs depsDirect depsTrans testDirect testTrans) =
247− let
248− directs =
249− Map.union depsDirect testDirect
250−
251− directAndTrans =
252− Map.union directs (Map.union depsTrans testTrans)
253−
254− try toConstraint deps =
255− do solution <- Solver.solve $ Map.insert pkg C.anything (Map.map toConstraint deps)
256− let newDepsDirect = Map.intersection solution (Map.insert pkg V.one depsDirect)
257− newDeps <- lift $ foldM (collectTransitive solution) Map.empty (Map.keys newDepsDirect)
258− return $
259− AppAnswer
260− { _old = directAndTrans
261− , _new = solution
262− , _info =
263− Project.AppInfo
264− elm
265− srcDirs
266− newDepsDirect
267− (Map.difference newDeps newDepsDirect)
268− (Map.intersection solution testDirect)
269− (Map.difference (Map.difference solution newDeps) testDirect)
270− }
271− in
272− msum
273− [ try C.exactly directAndTrans
274− , try C.exactly directs
275− , try C.untilNextMinor directs
276− , try C.untilNextMajor directs
277− , try (\_ -> C.anything) directs
278− ]
279−
280−
281−collectTransitive
282− :: Map.Map Pkg.Name V.Version
283− -> Map.Map Pkg.Name V.Version
284− -> Pkg.Name
285− -> Explorer (Map.Map Pkg.Name V.Version)
286−collectTransitive solution state name =
287− do let version = solution ! name
288− (Explorer.Info _ trans) <- Explorer.getConstraints name version
289− foldM
290− (collectTransitive solution)
291− (Map.insert name version state)
292− (Map.keys trans)
293−
294−
295−
296−
297−
298−-- ADD TO PKG
299−
300−
301−addToPkg :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Map.Map Pkg.Name (Change C.Constraint))
302−addToPkg registry pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
303− Explorer.run registry $
304− do Explorer.exists pkg
305− let old = Map.union deps tests
306− result <- Solver.run (addToPkgHelp pkg info)
307− case result of
308− Just new ->
309− return $ detectChanges old new
310−
311− Nothing ->
312− do let pkgs = Map.keys deps ++ Map.keys tests
313− badNames <- filterM isBadElm (pkg : pkgs)
314− lift $ Task.throw (Exit.Install (E.NoSolution badNames))
315−
316−
317−addToPkgHelp :: Pkg.Name -> Project.PkgInfo -> Solver.Solver (Map.Map Pkg.Name C.Constraint)
318−addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
319− do let directs = Map.union deps tests
320− let newCons = Map.insert pkg C.anything directs
321− solution <- Solver.solve newCons
322− let con = C.untilNextMajor (solution ! pkg)
323− return $ Map.insert pkg con directs
324−
325−
326−
327−-- FAILURE HINTS
328−
329−
330−isBadElm :: Pkg.Name -> Explorer Bool
331−isBadElm name =
332− do versions <- Explorer.getVersions name
333−
334− elmVersions <- forM versions $ \vsn ->
335− Explorer._elm <$> Explorer.getConstraints name vsn
336−
337− return (not (any C.goodElm elmVersions))
338−
339−
340−
341−-- VIEW CHANGE DOCS
342−
343−
344−data ChangeDocs =
345− Docs
346− { _doc_inserts :: [D.Doc]
347− , _doc_changes :: [D.Doc]
348− , _doc_removes :: [D.Doc]
349− }
350−
351−
352−viewChangeDocs :: ChangeDocs -> D.Doc
353−viewChangeDocs (Docs inserts changes removes) =
354− D.indent 2 $ D.vcat $ concat $
355− [ viewNonZero "Add:" inserts
356− , viewNonZero "Change:" changes
357− , viewNonZero "Remove:" removes
358− ]
359−
360−
361−viewNonZero :: String -> [D.Doc] -> [D.Doc]
362−viewNonZero title entries =
363− if null entries then
364− []
365− else
366− [ ""
367− , D.fromChars title
368− , D.indent 2 (D.vcat entries)
369− ]
370−
371−
372−
373−-- VIEW CHANGE
374−
375−
376−addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs
377−addChange toChars widths name change (Docs inserts changes removes) =
378− case change of
379− Insert new ->
380− Docs (viewInsert toChars widths name new : inserts) changes removes
381−
382− Change old new ->
383− Docs inserts (viewChange toChars widths name old new : changes) removes
384−
385− Remove old ->
386− Docs inserts changes (viewRemove toChars widths name old : removes)
387−
388−
389−viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
390−viewInsert toChars (Widths nameWidth leftWidth _) name new =
391− viewName nameWidth name <+> pad leftWidth (toChars new)
392−
393−
394−viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc
395−viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =
396− D.hsep
397− [ viewName nameWidth name
398− , pad leftWidth (toChars old)
399− , "=>"
400− , pad rightWidth (toChars new)
401− ]
402−
403−
404−viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
405−viewRemove toChars (Widths nameWidth leftWidth _) name old =
406− viewName nameWidth name <+> pad leftWidth (toChars old)
407−
408−
409−viewName :: Int -> Pkg.Name -> D.Doc
410−viewName width name =
411− D.fill (width + 3) (D.fromUtf8 (Pkg.toString name))
412−
413−
414−pad :: Int -> String -> D.Doc
415−pad width string =
416− D.fromChars (replicate (width - length string) ' ') <> D.fromChars string
417−
418−
419−
420−-- WIDTHS
421−
422−
423−data Widths =
424− Widths
425− { _name :: !Int
426− , _left :: !Int
427− , _right :: !Int
428− }
429−
430−
431−widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths
432−widen toChars pkg change (Widths name left right) =
433− let
434− toLength a =
435− length (toChars a)
436−
437− newName =
438− max name (length (Pkg.toChars pkg))
439− in
440− case change of
441− Insert new ->
442− Widths newName (max left (toLength new)) right
443−
444− Change old new ->
445− Widths newName (max left (toLength old)) (max right (toLength new))
446−
447− Remove old ->
448− Widths newName (max left (toLength old)) right
terminal/src/Install.hs+416−14
@@ -1,3 +1,4 @@
1+{-# LANGUAGE OverloadedStrings #-}
1module Install
2module Install
2 ( Args(..)
3 ( Args(..)
3 , run
4 , run
@@ -5,15 +6,23 @@ module Install
5 where
6 where
6
7
7
8
8−import Control.Monad.Trans (liftIO)
9+import Data.Map ((!))
10+import qualified Data.Map as Map
11+import qualified Data.Map.Merge.Strict as Map
9
12
10−import qualified Elm.Install as Install
13+import qualified Deps.Solver as Solver
14+import qualified Deps.Registry as Registry
15+import qualified Elm.Constraint as C
11−import qualified Elm.PerUserCache as PerUserCache
16+import qualified Elm.Details as Details
12import qualified Elm.Package as Pkg
17import qualified Elm.Package as Pkg
18+import qualified Elm.Outline as Outline
19+import qualified Elm.Version as V
20+import qualified Reporting
21+import Reporting.Doc ((<>), (<+>))
22+import qualified Reporting.Doc as D
13import qualified Reporting.Exit as Exit
23import qualified Reporting.Exit as Exit
14−import qualified Reporting.Exit.Install as E
15import qualified Reporting.Task as Task
24import qualified Reporting.Task as Task
16−import qualified Reporting.Progress.Terminal as Terminal
25+import qualified Stuff
17
26
18
27
19
28
@@ -27,12 +36,405 @@ data Args
27
36
28run :: Args -> () -> IO ()
37run :: Args -> () -> IO ()
29run args () =
38run args () =
30− do reporter <- Terminal.create
39+ Reporting.attempt Exit.installToReport $
31− Task.run reporter $
40+ do maybeRoot <- Stuff.findRoot
41+ case maybeRoot of
42+ Nothing ->
43+ return (Left Exit.InstallNoProject)
44+
45+ Just root ->
32− case args of
46+ case args of
33− NoArgs ->
47+ NoArgs ->
34− do elmHome <- liftIO PerUserCache.getElmHome
48+ do elmHome <- Stuff.getElmHome
35− Task.throw (Exit.Install (E.NoArgs elmHome))
49+ return (Left (Exit.InstallNoArgs elmHome))
36−
50+
37− Install pkg ->
51+ Install pkg ->
38− Install.install pkg
52+ Task.run $
53+ do env <- getEnv
54+ oldOutline <- getOutline root
55+ case oldOutline of
56+ Outline.App outline ->
57+ do changes <- makeAppPlan env pkg outline
58+ attemptChanges root env oldOutline V.toChars changes
59+
60+ Outline.Pkg outline ->
61+ do changes <- makePkgPlan env pkg outline
62+ attemptChanges root env oldOutline C.toChars changes
63+
64+
65+
66+getEnv :: Task Solver.Env
67+getEnv =
68+ do eitherEnv <- Task.io Solver.initEnv
69+ case eitherEnv of
70+ Right env -> return env
71+ Left problem -> Task.throw (error "TODO getEnv" problem)
72+
73+
74+getOutline :: FilePath -> Task Outline.Outline
75+getOutline root =
76+ do eitherOutline <- Task.io (Outline.read root)
77+ case eitherOutline of
78+ Right outline -> return outline
79+ Left exit -> Task.throw (error "TODO getOutline" exit)
80+
81+
82+
83+-- ATTEMPT CHANGES
84+
85+
86+data Changes vsn
87+ = AlreadyInstalled
88+ | PromoteTest Outline.Outline
89+ | PromoteIndirect Outline.Outline
90+ | Changes (Map.Map Pkg.Name (Change vsn)) Outline.Outline
91+
92+
93+type Task = Task.Task Exit.Install
94+
95+
96+attemptChanges :: FilePath -> Solver.Env -> Outline.Outline -> (a -> String) -> Changes a -> Task ()
97+attemptChanges root env oldOutline toChars changes =
98+ case changes of
99+ AlreadyInstalled ->
100+ Task.io $ putStrLn "It is already installed!"
101+
102+ PromoteIndirect newOutline ->
103+ attemptChangesHelp root env oldOutline newOutline $
104+ D.vcat
105+ [ D.fillSep
106+ ["I","found","it","in","your","elm.json","file,"
107+ ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."
108+ ]
109+ , D.fillSep
110+ ["Should","I","move","it","into",D.green "\"direct\""
111+ ,"dependencies","for","more","general","use?","[Y/n]: "
112+ ]
113+ ]
114+
115+ PromoteTest newOutline ->
116+ attemptChangesHelp root env oldOutline newOutline $
117+ D.vcat
118+ [ D.fillSep
119+ ["I","found","it","in","your","elm.json","file,"
120+ ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."
121+ ]
122+ , D.fillSep
123+ ["Should","I","move","it","into",D.green "\"dependencies\""
124+ ,"for","more","general","use?","[Y/n]: "
125+ ]
126+ ]
127+
128+ Changes changeDict newOutline ->
129+ let
130+ widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict
131+ changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict
132+ in
133+ attemptChangesHelp root env oldOutline newOutline $ D.vcat $
134+ [ "Here is my plan:"
135+ , viewChangeDocs changeDocs
136+ , ""
137+ , "Would you like me to update your elm.json accordingly? [Y/n]: "
138+ ]
139+
140+
141+attemptChangesHelp :: FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> D.Doc -> Task ()
142+attemptChangesHelp root env oldOutline newOutline question =
143+ Task.eio Exit.InstallHasBadDetails $
144+ do approved <- Reporting.ask question
145+ if approved
146+ then
147+ do Outline.write root newOutline
148+ result <- Details.verifyInstall root env newOutline
149+ case result of
150+ Left exit ->
151+ do Outline.write root oldOutline
152+ return (Left exit)
153+
154+ Right () ->
155+ do putStrLn "Success!"
156+ return (Right ())
157+ else
158+ do putStrLn "Okay, I did not change anything!"
159+ return (Right ())
160+
161+
162+
163+-- MAKE APP PLAN
164+
165+
166+makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version)
167+makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
168+ if Map.member pkg direct then
169+ return AlreadyInstalled
170+
171+ else
172+ -- is it already indirect?
173+ case Map.lookup pkg indirect of
174+ Just vsn ->
175+ return $ PromoteIndirect $ Outline.App $
176+ outline
177+ { Outline._app_deps_direct = Map.insert pkg vsn direct
178+ , Outline._app_deps_indirect = Map.delete pkg indirect
179+ }
180+
181+ Nothing ->
182+ -- is it already a test dependency?
183+ case Map.lookup pkg testDirect of
184+ Just vsn ->
185+ return $ PromoteTest $ Outline.App $
186+ outline
187+ { Outline._app_deps_direct = Map.insert pkg vsn direct
188+ , Outline._app_test_direct = Map.delete pkg testDirect
189+ }
190+
191+ Nothing ->
192+ -- is it already an indirect test dependency?
193+ case Map.lookup pkg testIndirect of
194+ Just vsn ->
195+ return $ PromoteTest $ Outline.App $
196+ outline
197+ { Outline._app_deps_direct = Map.insert pkg vsn direct
198+ , Outline._app_test_indirect = Map.delete pkg testIndirect
199+ }
200+
201+ Nothing ->
202+ -- finally try to add it from scratch
203+ case Registry.getVersions' pkg registry of
204+ Left suggestions ->
205+ case connection of
206+ Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline suggestions)
207+ Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline suggestions)
208+
209+ Right _ ->
210+ do result <- Task.io $ Solver.addToApp cache connection registry pkg outline
211+ case result of
212+ Solver.Ok (Solver.AppSolution old new app) ->
213+ return (Changes (detectChanges old new) (Outline.App app))
214+
215+ Solver.NoSolution ->
216+ Task.throw Exit.InstallNoOnlineSolution
217+
218+ Solver.NoOfflineSolution ->
219+ Task.throw Exit.InstallNoOfflineSolution
220+
221+ Solver.Err exit ->
222+ Task.throw (Exit.InstallHadSolverTrouble exit)
223+
224+
225+
226+-- MAKE PACKAGE PLAN
227+
228+
229+makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint)
230+makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps test _) =
231+ if Map.member pkg deps then
232+ return AlreadyInstalled
233+ else
234+ -- is already in test dependencies?
235+ case Map.lookup pkg test of
236+ Just con ->
237+ return $ PromoteTest $ Outline.Pkg $
238+ outline
239+ { Outline._pkg_deps = Map.insert pkg con deps
240+ , Outline._pkg_test_deps = Map.delete pkg test
241+ }
242+
243+ Nothing ->
244+ -- try to add a new dependency
245+ case Registry.getVersions' pkg registry of
246+ Left suggestions ->
247+ case connection of
248+ Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline suggestions)
249+ Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline suggestions)
250+
251+ Right (Registry.KnownVersions _ _) ->
252+ do let old = Map.union deps test
253+ let cons = Map.insert pkg C.anything old
254+ result <- Task.io $ Solver.verify cache connection registry cons
255+ case result of
256+ Solver.Ok solution ->
257+ let
258+ (Solver.Details vsn _) = solution ! pkg
259+
260+ con = C.untilNextMajor vsn
261+ new = Map.insert pkg con old
262+ changes = detectChanges old new
263+ news = Map.mapMaybe keepNew changes
264+ in
265+ return $ Changes changes $ Outline.Pkg $
266+ outline
267+ { Outline._pkg_deps = addNews (Just pkg) news deps
268+ , Outline._pkg_test_deps = addNews Nothing news test
269+ }
270+
271+ Solver.NoSolution ->
272+ Task.throw Exit.InstallNoOnlineSolution
273+
274+ Solver.NoOfflineSolution ->
275+ Task.throw Exit.InstallNoOfflineSolution
276+
277+ Solver.Err exit ->
278+ Task.throw (Exit.InstallHadSolverTrouble exit)
279+
280+
281+addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint
282+addNews pkg new old =
283+ Map.merge
284+ Map.preserveMissing
285+ (Map.mapMaybeMissing (\k c -> if Just k == pkg then Just c else Nothing))
286+ (Map.zipWithMatched (\_ _ n -> n))
287+ old
288+ new
289+
290+
291+
292+-- CHANGES
293+
294+
295+data Change a
296+ = Insert a
297+ | Change a a
298+ | Remove a
299+
300+
301+detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)
302+detectChanges old new =
303+ Map.merge
304+ (Map.mapMissing (\_ v -> Remove v))
305+ (Map.mapMissing (\_ v -> Insert v))
306+ (Map.zipWithMaybeMatched keepChange)
307+ old
308+ new
309+
310+
311+keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
312+keepChange _ old new =
313+ if old == new then
314+ Nothing
315+ else
316+ Just (Change old new)
317+
318+
319+keepNew :: Change a -> Maybe a
320+keepNew change =
321+ case change of
322+ Insert a ->
323+ Just a
324+
325+ Change _ a ->
326+ Just a
327+
328+ Remove _ ->
329+ Nothing
330+
331+
332+
333+-- VIEW CHANGE DOCS
334+
335+
336+data ChangeDocs =
337+ Docs
338+ { _doc_inserts :: [D.Doc]
339+ , _doc_changes :: [D.Doc]
340+ , _doc_removes :: [D.Doc]
341+ }
342+
343+
344+viewChangeDocs :: ChangeDocs -> D.Doc
345+viewChangeDocs (Docs inserts changes removes) =
346+ D.indent 2 $ D.vcat $ concat $
347+ [ viewNonZero "Add:" inserts
348+ , viewNonZero "Change:" changes
349+ , viewNonZero "Remove:" removes
350+ ]
351+
352+
353+viewNonZero :: String -> [D.Doc] -> [D.Doc]
354+viewNonZero title entries =
355+ if null entries then
356+ []
357+ else
358+ [ ""
359+ , D.fromChars title
360+ , D.indent 2 (D.vcat entries)
361+ ]
362+
363+
364+
365+-- VIEW CHANGE
366+
367+
368+addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs
369+addChange toChars widths name change (Docs inserts changes removes) =
370+ case change of
371+ Insert new ->
372+ Docs (viewInsert toChars widths name new : inserts) changes removes
373+
374+ Change old new ->
375+ Docs inserts (viewChange toChars widths name old new : changes) removes
376+
377+ Remove old ->
378+ Docs inserts changes (viewRemove toChars widths name old : removes)
379+
380+
381+viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
382+viewInsert toChars (Widths nameWidth leftWidth _) name new =
383+ viewName nameWidth name <+> pad leftWidth (toChars new)
384+
385+
386+viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc
387+viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =
388+ D.hsep
389+ [ viewName nameWidth name
390+ , pad leftWidth (toChars old)
391+ , "=>"
392+ , pad rightWidth (toChars new)
393+ ]
394+
395+
396+viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
397+viewRemove toChars (Widths nameWidth leftWidth _) name old =
398+ viewName nameWidth name <+> pad leftWidth (toChars old)
399+
400+
401+viewName :: Int -> Pkg.Name -> D.Doc
402+viewName width name =
403+ D.fill (width + 3) (D.fromUtf8 (Pkg.toString name))
404+
405+
406+pad :: Int -> String -> D.Doc
407+pad width string =
408+ D.fromChars (replicate (width - length string) ' ') <> D.fromChars string
409+
410+
411+
412+-- WIDTHS
413+
414+
415+data Widths =
416+ Widths
417+ { _name :: !Int
418+ , _left :: !Int
419+ , _right :: !Int
420+ }
421+
422+
423+widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths
424+widen toChars pkg change (Widths name left right) =
425+ let
426+ toLength a =
427+ length (toChars a)
428+
429+ newName =
430+ max name (length (Pkg.toChars pkg))
431+ in
432+ case change of
433+ Insert new ->
434+ Widths newName (max left (toLength new)) right
435+
436+ Change old new ->
437+ Widths newName (max left (toLength old)) (max right (toLength new))
438+
439+ Remove old ->
440+ Widths newName (max left (toLength old)) right