git.iko.soy/elk
on 6a96e21 help sign in
elk/builder/src/Elm/Install.hs
358 lines 9.2 kB history raw
1module Elm.Install
2 ( install
3 )
4 where
7import Control.Monad (filterM, forM, msum, void)
8import Control.Monad.Except (catchError, lift, liftIO)
9import Data.Map (Map, (!))
10import qualified Data.Map as Map
11import qualified Data.Map.Merge.Lazy as Map
12import qualified System.IO as IO
13import Text.PrettyPrint.ANSI.Leijen ((<>), (<+>))
14import qualified Text.PrettyPrint.ANSI.Leijen as P
16import qualified Elm.Package as Pkg
17import Elm.Package (Name, Version)
19import Deps.Explorer (Explorer)
20import qualified Deps.Explorer as Explorer
21import qualified Deps.Verify as Verify
22import qualified Deps.Solver as Solver
23import Elm.Project.Constraint (Constraint)
24import qualified Elm.Project.Constraint as Con
25import qualified Elm.Project.Json as Project
26import qualified Elm.Project.Root as Root
27import qualified Reporting.Exit as Exit
28import qualified Reporting.Task as Task
32-- INSTALL
35install :: Name -> Task.Task ()
36install pkg =
37 do (root, oldProject) <- Root.unsafeGet
38 makePlan pkg oldProject $ \newProject ->
39 let
40 upgrade =
41 do liftIO $ Project.write root newProject
42 void $ Verify.verify root newProject
44 revert err =
45 do liftIO $ Project.write root oldProject
46 Task.throw err
47 in
48 upgrade `catchError` revert
52-- MAKE PLAN
55makePlan :: Name -> Project.Project -> (Project.Project -> Task.Task ()) -> Task.Task ()
56makePlan pkg project attemptInstall =
57 case project of
58 Project.App info@(Project.AppInfo elm srcDirs deps test trans) ->
59 do changes <- addToApp pkg info
61 let news = Map.mapMaybe keepNew changes
62 let newDeps = addNews (Just pkg) news deps
63 let newTest = addNews Nothing news test
64 let newTrans = Map.union (Map.difference news (Map.union newDeps newTest)) trans
65 let newInfo = Project.AppInfo elm srcDirs newDeps newTest newTrans
66 let newProject = Project.App newInfo
68 withApproval Pkg.versionToString changes (attemptInstall newProject)
70 Project.Pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) ->
71 do changes <- addToPkg pkg info
73 let news = Map.mapMaybe keepNew changes
74 let newProject = Project.Pkg $
75 info
76 { Project._pkg_deps = addNews (Just pkg) news deps
77 , Project._pkg_test_deps = addNews Nothing news test
78 }
80 withApproval (show . Con.toString) changes (attemptInstall newProject)
83addNews :: Maybe Name -> Map Name a -> Map Name a -> Map Name a
84addNews pkg new old =
85 Map.merge
86 Map.preserveMissing
87 (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))
88 (Map.zipWithMatched (\_ _ n -> n))
89 old
90 new
94-- CHANGES
97data Change a
98 = Insert a
99 | Change a a
100 | Remove a
103detectChanges :: (Eq a) => Map Name a -> Map Name a -> Map Name (Change a)
104detectChanges old new =
105 Map.merge
106 (Map.mapMissing (\_ v -> Remove v))
107 (Map.mapMissing (\_ v -> Insert v))
108 (Map.zipWithMaybeMatched keepChange)
109 old
110 new
113keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
114keepChange _ old new =
115 if old == new then
116 Nothing
117 else
118 Just (Change old new)
121keepNew :: Change a -> Maybe a
122keepNew change =
123 case change of
124 Insert a ->
125 Just a
127 Change _ a ->
128 Just a
130 Remove _ ->
131 Nothing
135-- ADD TO APP
138addToApp :: Name -> Project.AppInfo -> Task.Task (Map Name (Change Version))
139addToApp pkg info@(Project.AppInfo _ _ deps tests trans) =
140 Explorer.run $
141 do Explorer.exists pkg
142 let old = Map.unions [ deps, tests, trans ]
143 result <- Solver.run (addToAppHelp pkg info)
144 case result of
145 Just new ->
146 return $ detectChanges old new
148 Nothing ->
149 do badNames <- filterM isBadElm (pkg : Map.keys old)
150 lift $ Task.throw (Exit.NoSolution badNames)
153addToAppHelp :: Name -> Project.AppInfo -> Solver.Solver (Map Name Version)
154addToAppHelp pkg (Project.AppInfo _ _ deps tests trans) =
155 let
156 directs =
157 Map.union deps tests
159 everything =
160 Map.union directs trans
162 try constraints =
163 Solver.solve $ Map.insert pkg Con.anything constraints
164 in
165 msum $ map try $
166 [ Map.map Con.exactly everything
167 , Map.map Con.exactly directs
168 , Map.map Con.untilNextMinor directs
169 , Map.map Con.untilNextMajor directs
170 , Map.map (\_ -> Con.anything) directs
171 ]
175-- ADD TO PKG
178addToPkg :: Name -> Project.PkgInfo -> Task.Task (Map Name (Change Constraint))
179addToPkg pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
180 Explorer.run $
181 do Explorer.exists pkg
182 let old = Map.union deps tests
183 result <- Solver.run (addToPkgHelp pkg info)
184 case result of
185 Just new ->
186 return $ detectChanges old new
188 Nothing ->
189 do let pkgs = Map.keys deps ++ Map.keys tests
190 badNames <- filterM isBadElm (pkg : pkgs)
191 lift $ Task.throw (Exit.NoSolution badNames)
194addToPkgHelp :: Name -> Project.PkgInfo -> Solver.Solver (Map Name Constraint)
195addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
196 do let directs = Map.union deps tests
197 let newCons = Map.insert pkg Con.anything directs
198 solution <- Solver.solve newCons
199 let con = Con.untilNextMajor (solution ! pkg)
200 return $ Map.insert pkg con directs
204-- FAILURE HINTS
207isBadElm :: Name -> Explorer Bool
208isBadElm name =
209 do versions <- Explorer.getVersions name
211 elmVersions <- forM versions $ \vsn ->
212 Explorer._elm <$> Explorer.getConstraints name vsn
214 return (not (any Con.goodElm elmVersions))
218-- VIEW
221withApproval :: (a -> String) -> Map Name (Change a) -> Task.Task () -> Task.Task ()
222withApproval toString changes attemptInstall =
223 let
224 widths =
225 Map.foldrWithKey (widen toString) (Widths 0 0 0) changes
227 changeDocs =
228 Map.foldrWithKey (addChange toString widths) (Docs [] [] []) changes
230 printDoc doc =
231 P.displayIO IO.stdout $ P.renderPretty 1 80 doc
232 in
233 case changeDocs of
234 Docs [] [] [] ->
235 do liftIO $ putStrLn "Already installed. No changes necessary!"
237 Docs inserts [] [] ->
238 do liftIO $ putStrLn "Adding the following dependencies:\n"
239 liftIO $ printDoc $ P.indent 2 (P.vcat (reverse inserts))
240 liftIO $ putStrLn "\n"
241 attemptInstall
243 Docs _ _ _ ->
244 do liftIO $ putStrLn "Here is my plan:"
245 liftIO $ printDoc $ viewChangeDocs changeDocs
246 liftIO $ putStrLn "\nDo you approve? [Y/n]: "
247 Task.withApproval attemptInstall
251-- VIEW CHANGE DOCS
254data ChangeDocs =
255 Docs
256 { _doc_inserts :: [P.Doc]
257 , _doc_changes :: [P.Doc]
258 , _doc_removes :: [P.Doc]
259 }
262viewChangeDocs :: ChangeDocs -> P.Doc
263viewChangeDocs (Docs inserts changes removes) =
264 P.indent 2 $ P.vcat $ concat $
265 [ viewNonZero "Add:" inserts
266 , viewNonZero "Change:" changes
267 , viewNonZero "Remove:" removes
268 ]
271viewNonZero :: String -> [P.Doc] -> [P.Doc]
272viewNonZero title entries =
273 if null entries then
274 []
275 else
276 [ P.text ""
277 , P.text title
278 , P.indent 2 (P.vcat (reverse entries))
279 ]
283-- VIEW CHANGE
286addChange :: (a -> String) -> Widths -> Name -> Change a -> ChangeDocs -> ChangeDocs
287addChange toString widths name change (Docs inserts changes removes) =
288 case change of
289 Insert new ->
290 Docs (viewInsert toString widths name new : inserts) changes removes
292 Change old new ->
293 Docs inserts (viewChange toString widths name old new : changes) removes
295 Remove old ->
296 Docs inserts changes (viewRemove toString widths name old : removes)
299viewInsert :: (a -> String) -> Widths -> Name -> a -> P.Doc
300viewInsert toString (Widths nameWidth leftWidth _) name new =
301 viewName nameWidth name <+> pad leftWidth (toString new)
304viewChange :: (a -> String) -> Widths -> Name -> a -> a -> P.Doc
305viewChange toString (Widths nameWidth leftWidth rightWidth) name old new =
306 P.hsep
307 [ viewName nameWidth name
308 , pad leftWidth (toString old)
309 , P.text "=>"
310 , pad rightWidth (toString new)
311 ]
314viewRemove :: (a -> String) -> Widths -> Name -> a -> P.Doc
315viewRemove toString (Widths nameWidth leftWidth _) name old =
316 viewName nameWidth name <+> pad leftWidth (toString old)
319viewName :: Int -> Name -> P.Doc
320viewName width name =
321 P.fill (width + 3) (P.text (Pkg.toString name))
324pad :: Int -> String -> P.Doc
325pad width string =
326 P.text (replicate (width - length string) ' ') <> P.text string
330-- WIDTHS
333data Widths =
334 Widths
335 { _name :: !Int
336 , _left :: !Int
337 , _right :: !Int
338 }
341widen :: (a -> String) -> Name -> Change a -> Widths -> Widths
342widen toString pkg change (Widths name left right) =
343 let
344 toLength a =
345 length (toString a)
347 newName =
348 max name (length (Pkg.toString pkg))
349 in
350 case change of
351 Insert new ->
352 Widths newName (max left (toLength new)) right
354 Change old new ->
355 Widths newName (max left (toLength old)) (max right (toLength new))
357 Remove old ->
358 Widths newName (max left (toLength old)) right