@@ -5,7 +5,7 @@ module Elm.Install
55 where
66
77
8−import Control.Monad (filterM, forM, msum, void)
8+import Control.Monad (filterM, foldM, forM, msum, void)
99import Control.Monad.Except (catchError, lift, liftIO)
1010import Data.Map ((!))
1111import qualified Data.Map as Map
@@ -69,11 +69,31 @@ attemptElmJsonChange root oldProject toString changes =
6969 AlreadyInstalled ->
7070 do liftIO $ putStrLn "It is already installed!"
7171
72− PromoteTest newProject ->
73− attempt newProject $ requestPromotion "\"test-dependencies\""
74−
7572 PromoteTrans newProject ->
76− attempt newProject $ requestPromotion "\"transitive-dependencies\""
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+ ]
7797
7898 Changes changeDict newProject ->
7999 let
@@ -88,20 +108,6 @@ attemptElmJsonChange root oldProject toString changes =
88108 ]
89109
90110
91−requestPromotion :: D.Doc -> D.Doc
92−requestPromotion theWrongPlace =
93− D.vcat
94− [ D.fillSep
95− ["I","found","it","in","your","elm.json","file!"
96− ,"In",D.dullyellow theWrongPlace,"though."
97− ]
98− , D.fillSep
99− ["Should","I","move","it","into",D.green "\"dependencies\""
100− ,"for","more","general","use?","[Y/n]: "
101− ]
102− ]
103−
104−
105111
106112-- MAKE PLANS
107113
@@ -114,31 +120,21 @@ data Changes vsn
114120
115121
116122makeAppPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task (Changes Pkg.Version)
117−makeAppPlan registry pkg info@(Project.AppInfo elm srcDirs deps test trans) =
118− if Map.member pkg deps then
123+makeAppPlan registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
124+ if Map.member pkg depsDirect then
119125 return AlreadyInstalled
120126 else
121− case Map.lookup pkg test of
122− Just vsn ->
123− return $ PromoteTest $ Project.App $
124− Project.AppInfo elm srcDirs (Map.insert pkg vsn deps) (Map.delete pkg test) trans
127+ do (AppAnswer old new newInfo) <- toAppAnswer registry pkg info
125128
126− Nothing ->
127− case Map.lookup pkg trans of
128− Just vsn ->
129− return $ PromoteTrans $ Project.App $
130− Project.AppInfo elm srcDirs (Map.insert pkg vsn deps) test (Map.delete pkg trans)
131−
132− Nothing ->
133− do changes <- addToApp registry pkg info
129+ return $
130+ if Map.member pkg depsTrans then
131+ PromoteTrans (Project.App newInfo)
134132
135− let news = Map.mapMaybe keepNew changes
136− let newDeps = addNews (Just pkg) news deps
137− let newTest = addNews Nothing news test
138− let newTrans = Map.union (Map.difference news (Map.union newDeps newTest)) trans
133+ else if Map.member pkg testDirect || Map.member pkg testTrans then
134+ PromoteTest (Project.App newInfo)
139135
140− return $ Changes changes $ Project.App $
141− Project.AppInfo elm srcDirs newDeps newTest newTrans
136+ else
137+ Changes (detectChanges old new) (Project.App newInfo)
142138
143139
144140makePkgPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Changes Constraint)
@@ -219,40 +215,83 @@ keepNew change =
219215-- ADD TO APP
220216
221217
222−addToApp :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task (Map.Map Pkg.Name (Change Pkg.Version))
223−addToApp registry pkg info@(Project.AppInfo _ _ deps tests trans) =
218+data AppAnswer =
219+ AppAnswer
220+ { _old :: Map.Map Pkg.Name Pkg.Version
221+ , _new :: Map.Map Pkg.Name Pkg.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) =
224228 Explorer.run registry $
225229 do Explorer.exists pkg
226− let old = Map.unions [ deps, tests, trans ]
227− result <- Solver.run (addToAppHelp pkg info)
230+ result <- Solver.run (toAppAnswerHelp pkg info)
228231 case result of
229− Just new ->
230− return $ detectChanges old new
232+ Just answer ->
233+ return answer
231234
232235 Nothing ->
233− do badNames <- filterM isBadElm (pkg : Map.keys old)
236+ do badNames <-
237+ filterM isBadElm $
238+ pkg : Map.keys depsDirect
239+ ++ Map.keys depsTrans
240+ ++ Map.keys testDirect
241+ ++ Map.keys testTrans
234242 lift $ Task.throw (Exit.Install (E.NoSolution badNames))
235243
236244
237−addToAppHelp :: Pkg.Name -> Project.AppInfo -> Solver.Solver (Map.Map Pkg.Name Pkg.Version)
238−addToAppHelp pkg (Project.AppInfo _ _ deps tests trans) =
245+toAppAnswerHelp :: Pkg.Name -> Project.AppInfo -> Solver.Solver AppAnswer
246+toAppAnswerHelp pkg (Project.AppInfo elm srcDirs depsDirect depsTrans testDirect testTrans) =
239247 let
240248 directs =
241− Map.union deps tests
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 Con.anything (Map.map toConstraint deps)
256+ let newDepsDirect = Map.intersection solution (Map.insert pkg Pkg.dummyVersion 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 Con.exactly directAndTrans
274+ , try Con.exactly directs
275+ , try Con.untilNextMinor directs
276+ , try Con.untilNextMajor directs
277+ , try (\_ -> Con.anything) directs
278+ ]
279+
280+
281+collectTransitive
282+ :: Map.Map Pkg.Name Pkg.Version
283+ -> Map.Map Pkg.Name Pkg.Version
284+ -> Pkg.Name
285+ -> Explorer (Map.Map Pkg.Name Pkg.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)
242293
243− everything =
244− Map.union directs trans
245294
246− try constraints =
247− Solver.solve $ Map.insert pkg Con.anything constraints
248− in
249− msum $ map try $
250− [ Map.map Con.exactly everything
251− , Map.map Con.exactly directs
252− , Map.map Con.untilNextMinor directs
253− , Map.map Con.untilNextMajor directs
254− , Map.map (\_ -> Con.anything) directs
255− ]
256295
257296
258297
@@ -326,7 +365,7 @@ viewNonZero title entries =
326365 else
327366 [ ""
328367 , D.fromString title
329− , D.indent 2 (D.vcat (reverse entries))
368+ , D.indent 2 (D.vcat entries)
330369 ]
331370
332371