git.iko.soy/elk
on f4401ac help sign in
elk/terminal/src/Install.hs
423 lines 13 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Install
3 ( Args(..)
4 , run
5 )
6 where
9import Data.Map ((!))
10import qualified Data.Map as Map
11import qualified Data.Map.Merge.Strict as Map
13import qualified Deps.Solver as Solver
14import qualified Deps.Registry as Registry
15import qualified Elm.Constraint as C
16import qualified Elm.Details as Details
17import qualified Elm.Package as Pkg
18import qualified Elm.Outline as Outline
19import qualified Elm.Version as V
20import qualified Reporting
21import Reporting.Doc ((<>), (<+>))
22import qualified Reporting.Doc as D
23import qualified Reporting.Exit as Exit
24import qualified Reporting.Task as Task
25import qualified Stuff
29-- RUN
32data Args
33 = NoArgs
34 | Install Pkg.Name
37run :: Args -> () -> IO ()
38run args () =
39 Reporting.attempt Exit.installToReport $
40 do maybeRoot <- Stuff.findRoot
41 case maybeRoot of
42 Nothing ->
43 return (Left Exit.InstallNoOutline)
45 Just root ->
46 case args of
47 NoArgs ->
48 do elmHome <- Stuff.getElmHome
49 return (Left (Exit.InstallNoArgs elmHome))
51 Install pkg ->
52 Task.run $
53 do env <- Task.eio Exit.InstallBadRegistry $ Solver.initEnv
54 oldOutline <- Task.eio Exit.InstallBadOutline $ Outline.read root
55 case oldOutline of
56 Outline.App outline ->
57 do changes <- makeAppPlan env pkg outline
58 attemptChanges root env pkg oldOutline V.toChars changes
60 Outline.Pkg outline ->
61 do changes <- makePkgPlan env pkg outline
62 attemptChanges root env pkg oldOutline C.toChars changes
66-- ATTEMPT CHANGES
69data Changes vsn
70 = AlreadyInstalled
71 | PromoteTest Outline.Outline
72 | PromoteIndirect Outline.Outline
73 | Changes (Map.Map Pkg.Name (Change vsn)) Outline.Outline
76type Task = Task.Task Exit.Install
79attemptChanges :: FilePath -> Solver.Env -> Pkg.Name -> Outline.Outline -> (a -> String) -> Changes a -> Task ()
80attemptChanges root env pkg oldOutline toChars changes =
81 case changes of
82 AlreadyInstalled ->
83 Task.io $ putStrLn "It is already installed!"
85 PromoteIndirect newOutline ->
86 attemptChangesHelp root env pkg oldOutline newOutline $
87 D.vcat
88 [ D.fillSep
89 ["I","found","it","in","your","elm.json","file,"
90 ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."
91 ]
92 , D.fillSep
93 ["Should","I","move","it","into",D.green "\"direct\""
94 ,"dependencies","for","more","general","use?","[Y/n]: "
95 ]
96 ]
98 PromoteTest newOutline ->
99 attemptChangesHelp root env pkg oldOutline newOutline $
100 D.vcat
101 [ D.fillSep
102 ["I","found","it","in","your","elm.json","file,"
103 ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."
104 ]
105 , D.fillSep
106 ["Should","I","move","it","into",D.green "\"dependencies\""
107 ,"for","more","general","use?","[Y/n]: "
108 ]
109 ]
111 Changes changeDict newOutline ->
112 let
113 widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict
114 changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict
115 in
116 attemptChangesHelp root env pkg oldOutline newOutline $ D.vcat $
117 [ "Here is my plan:"
118 , viewChangeDocs changeDocs
119 , ""
120 , "Would you like me to update your elm.json accordingly? [Y/n]: "
121 ]
124attemptChangesHelp :: FilePath -> Solver.Env -> Pkg.Name -> Outline.Outline -> Outline.Outline -> D.Doc -> Task ()
125attemptChangesHelp root env pkg oldOutline newOutline question =
126 Task.eio (\_ -> Exit.InstallHasBadDetails pkg (Outline.encode newOutline)) $
127 do approved <- Reporting.ask question
128 if approved
129 then
130 do Outline.write root newOutline
131 result <- Details.verifyInstall root env newOutline
132 case result of
133 Left exit ->
134 do Outline.write root oldOutline
135 return (Left exit)
137 Right () ->
138 do putStrLn "Success!"
139 return (Right ())
140 else
141 do putStrLn "Okay, I did not change anything!"
142 return (Right ())
146-- MAKE APP PLAN
149makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version)
150makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
151 if Map.member pkg direct then
152 return AlreadyInstalled
154 else
155 -- is it already indirect?
156 case Map.lookup pkg indirect of
157 Just vsn ->
158 return $ PromoteIndirect $ Outline.App $
159 outline
160 { Outline._app_deps_direct = Map.insert pkg vsn direct
161 , Outline._app_deps_indirect = Map.delete pkg indirect
162 }
164 Nothing ->
165 -- is it already a test dependency?
166 case Map.lookup pkg testDirect of
167 Just vsn ->
168 return $ PromoteTest $ Outline.App $
169 outline
170 { Outline._app_deps_direct = Map.insert pkg vsn direct
171 , Outline._app_test_direct = Map.delete pkg testDirect
172 }
174 Nothing ->
175 -- is it already an indirect test dependency?
176 case Map.lookup pkg testIndirect of
177 Just vsn ->
178 return $ PromoteTest $ Outline.App $
179 outline
180 { Outline._app_deps_direct = Map.insert pkg vsn direct
181 , Outline._app_test_indirect = Map.delete pkg testIndirect
182 }
184 Nothing ->
185 -- finally try to add it from scratch
186 case Registry.getVersions' pkg registry of
187 Left suggestions ->
188 case connection of
189 Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
190 Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)
192 Right _ ->
193 do result <- Task.io $ Solver.addToApp cache connection registry pkg outline
194 case result of
195 Solver.Ok (Solver.AppSolution old new app) ->
196 return (Changes (detectChanges old new) (Outline.App app))
198 Solver.NoSolution ->
199 Task.throw Exit.InstallNoOnlineSolution
201 Solver.NoOfflineSolution ->
202 Task.throw Exit.InstallNoOfflineSolution
204 Solver.Err exit ->
205 Task.throw (Exit.InstallHadSolverTrouble exit)
209-- MAKE PACKAGE PLAN
212makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint)
213makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps test _) =
214 if Map.member pkg deps then
215 return AlreadyInstalled
216 else
217 -- is already in test dependencies?
218 case Map.lookup pkg test of
219 Just con ->
220 return $ PromoteTest $ Outline.Pkg $
221 outline
222 { Outline._pkg_deps = Map.insert pkg con deps
223 , Outline._pkg_test_deps = Map.delete pkg test
224 }
226 Nothing ->
227 -- try to add a new dependency
228 case Registry.getVersions' pkg registry of
229 Left suggestions ->
230 case connection of
231 Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
232 Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)
234 Right (Registry.KnownVersions _ _) ->
235 do let old = Map.union deps test
236 let cons = Map.insert pkg C.anything old
237 result <- Task.io $ Solver.verify cache connection registry cons
238 case result of
239 Solver.Ok solution ->
240 let
241 (Solver.Details vsn _) = solution ! pkg
243 con = C.untilNextMajor vsn
244 new = Map.insert pkg con old
245 changes = detectChanges old new
246 news = Map.mapMaybe keepNew changes
247 in
248 return $ Changes changes $ Outline.Pkg $
249 outline
250 { Outline._pkg_deps = addNews (Just pkg) news deps
251 , Outline._pkg_test_deps = addNews Nothing news test
252 }
254 Solver.NoSolution ->
255 Task.throw Exit.InstallNoOnlineSolution
257 Solver.NoOfflineSolution ->
258 Task.throw Exit.InstallNoOfflineSolution
260 Solver.Err exit ->
261 Task.throw (Exit.InstallHadSolverTrouble exit)
264addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint
265addNews pkg new old =
266 Map.merge
267 Map.preserveMissing
268 (Map.mapMaybeMissing (\k c -> if Just k == pkg then Just c else Nothing))
269 (Map.zipWithMatched (\_ _ n -> n))
270 old
271 new
275-- CHANGES
278data Change a
279 = Insert a
280 | Change a a
281 | Remove a
284detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)
285detectChanges old new =
286 Map.merge
287 (Map.mapMissing (\_ v -> Remove v))
288 (Map.mapMissing (\_ v -> Insert v))
289 (Map.zipWithMaybeMatched keepChange)
290 old
291 new
294keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
295keepChange _ old new =
296 if old == new then
297 Nothing
298 else
299 Just (Change old new)
302keepNew :: Change a -> Maybe a
303keepNew change =
304 case change of
305 Insert a ->
306 Just a
308 Change _ a ->
309 Just a
311 Remove _ ->
312 Nothing
316-- VIEW CHANGE DOCS
319data ChangeDocs =
320 Docs
321 { _doc_inserts :: [D.Doc]
322 , _doc_changes :: [D.Doc]
323 , _doc_removes :: [D.Doc]
324 }
327viewChangeDocs :: ChangeDocs -> D.Doc
328viewChangeDocs (Docs inserts changes removes) =
329 D.indent 2 $ D.vcat $ concat $
330 [ viewNonZero "Add:" inserts
331 , viewNonZero "Change:" changes
332 , viewNonZero "Remove:" removes
333 ]
336viewNonZero :: String -> [D.Doc] -> [D.Doc]
337viewNonZero title entries =
338 if null entries then
339 []
340 else
341 [ ""
342 , D.fromChars title
343 , D.indent 2 (D.vcat entries)
344 ]
348-- VIEW CHANGE
351addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs
352addChange toChars widths name change (Docs inserts changes removes) =
353 case change of
354 Insert new ->
355 Docs (viewInsert toChars widths name new : inserts) changes removes
357 Change old new ->
358 Docs inserts (viewChange toChars widths name old new : changes) removes
360 Remove old ->
361 Docs inserts changes (viewRemove toChars widths name old : removes)
364viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
365viewInsert toChars (Widths nameWidth leftWidth _) name new =
366 viewName nameWidth name <+> pad leftWidth (toChars new)
369viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc
370viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =
371 D.hsep
372 [ viewName nameWidth name
373 , pad leftWidth (toChars old)
374 , "=>"
375 , pad rightWidth (toChars new)
376 ]
379viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
380viewRemove toChars (Widths nameWidth leftWidth _) name old =
381 viewName nameWidth name <+> pad leftWidth (toChars old)
384viewName :: Int -> Pkg.Name -> D.Doc
385viewName width name =
386 D.fill (width + 3) (D.fromPackage name)
389pad :: Int -> String -> D.Doc
390pad width string =
391 D.fromChars (replicate (width - length string) ' ') <> D.fromChars string
395-- WIDTHS
398data Widths =
399 Widths
400 { _name :: !Int
401 , _left :: !Int
402 , _right :: !Int
403 }
406widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths
407widen toChars pkg change (Widths name left right) =
408 let
409 toLength a =
410 length (toChars a)
412 newName =
413 max name (length (Pkg.toChars pkg))
414 in
415 case change of
416 Insert new ->
417 Widths newName (max left (toLength new)) right
419 Change old new ->
420 Widths newName (max left (toLength old)) (max right (toLength new))
422 Remove old ->
423 Widths newName (max left (toLength old)) right