git.iko.soy/elk
on master help sign in
Revamp solver
f4b6b0fEvan Czaplicki
builder/src/Deps/Solver.hs+258−153
compare with master
unifiedsplit
@@ -1,14 +1,25 @@
1{-# LANGUAGE OverloadedStrings, Rank2Types #-}
1{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2module Deps.Solver
2module Deps.Solver
3− ( online
3+ ( Solver
4− , offline
4+ , Result(..)
5+ , Connection(..)
6+ --
5 , Details(..)
7 , Details(..)
8+ , verify
9+ --
10+ , AppSolution(..)
11+ , addToApp
12+ --
13+ , Env(..)
14+ , initEnv
6 )
15 )
7 where
16 where
8
17
9
18
10import Control.Monad (foldM)
19import Control.Monad (foldM)
20+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
11import qualified Data.Map as Map
21import qualified Data.Map as Map
22+import Data.Map ((!))
12import qualified System.Directory as Dir
23import qualified System.Directory as Dir
13import System.FilePath ((</>))
24import System.FilePath ((</>))
14
25
@@ -21,52 +32,11 @@ import qualified Elm.Version as V
21import qualified File
32import qualified File
22import qualified Http
33import qualified Http
23import qualified Json.Decode as D
34import qualified Json.Decode as D
35+import qualified Reporting.Exit as Exit
24import qualified Stuff
36import qualified Stuff
25
37
26
38
27
39
28−-- ONLINE / OFFLINE
29−
30−
31−online :: Stuff.PackageCache -> Http.Manager -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
32−online cache manager registry constraints =
33− solve cache (Online manager) registry constraints
34−
35−
36−offline :: Stuff.PackageCache -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
37−offline cache registry constraints =
38− solve cache Offline registry constraints
39−
40−
41−
42−-- SOLVE
43−
44−
45−data Details =
46− Details V.Version (Map.Map Pkg.Name C.Constraint)
47−
48−
49−solve :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
50−solve cache connection registry constraints =
51− let
52− (Solver solver) = exploreGoals (Goals constraints Map.empty)
53− in
54− solver (State cache connection registry Map.empty [])
55− (\(State _ _ _ cs _) vs _ -> return $ Right $ Map.mapWithKey (toDetails cs) vs)
56− (\(State _ _ _ _ ps) -> return $ Left ps)
57−
58−
59−toDetails :: Map.Map (Pkg.Name, V.Version) Constraints -> Pkg.Name -> V.Version -> Details
60−toDetails constraints name vsn =
61− case Map.lookup (name, vsn) constraints of
62− Just (Constraints _ deps) ->
63− Details vsn deps
64−
65− Nothing ->
66− error "compiler bug in Deps.Solver manifesting in toDetails"
67−
68−
69−
70-- SOLVER
40-- SOLVER
71
41
72
42
@@ -77,21 +47,17 @@ newtype Solver a =
77 State
47 State
78 -> (State -> a -> (State -> IO b) -> IO b)
48 -> (State -> a -> (State -> IO b) -> IO b)
79 -> (State -> IO b)
49 -> (State -> IO b)
50+ -> (Exit.Solver -> IO b)
80 -> IO b
51 -> IO b
81 )
52 )
82
53
83
54
84−
85−-- STATE
86−
87−
88data State =
55data State =
89 State
56 State
90 { _cache :: Stuff.PackageCache
57 { _cache :: Stuff.PackageCache
91− , _internet :: Connection
58+ , _connection :: Connection
92 , _registry :: Registry.Registry
59 , _registry :: Registry.Registry
93 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
60 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
94− , _problems :: [Problem]
95 }
61 }
96
62
97
63
@@ -107,13 +73,124 @@ data Connection
107 | Offline
73 | Offline
108
74
109
75
110−data Problem
76+
111− = BadCacheData Pkg.Name V.Version
77+-- RESULT
112− | BadHttpData Pkg.Name V.Version
78+
113− | BadHttp Http.Error
79+
114− | UnknownPackage [Pkg.Name]
80+data Result a
115− | ImpossibleConstraint Pkg.Name C.Constraint
81+ = Ok a
116− | UnavailableOffline Pkg.Name V.Version
82+ | NoSolution
83+ | NoOfflineSolution
84+ | Err Exit.Solver
85+
86+
87+
88+-- VERIFY -- used by Elm.Details
89+
90+
91+data Details =
92+ Details V.Version (Map.Map Pkg.Name C.Constraint)
93+
94+
95+verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96+verify cache connection registry constraints =
97+ case try constraints of
98+ Solver solver ->
99+ solver (State cache connection registry Map.empty)
100+ (\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
101+ (\_ -> return $ noSolution connection)
102+ (\e -> return $ Err e)
103+
104+
105+addDeps :: State -> Pkg.Name -> V.Version -> Details
106+addDeps (State _ _ _ constraints) name vsn =
107+ case Map.lookup (name, vsn) constraints of
108+ Just (Constraints _ deps) -> Details vsn deps
109+ Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
110+
111+
112+noSolution :: Connection -> Result a
113+noSolution connection =
114+ case connection of
115+ Online _ -> NoSolution
116+ Offline -> NoOfflineSolution
117+
118+
119+
120+-- ADD TO APP - used in Install
121+
122+
123+data AppSolution =
124+ AppSolution
125+ { _old :: Map.Map Pkg.Name V.Version
126+ , _new :: Map.Map Pkg.Name V.Version
127+ , _app :: Outline.AppOutline
128+ }
129+
130+
131+addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
132+addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
133+ let
134+ allIndirects = Map.union indirect testIndirect
135+ allDirects = Map.union direct testDirect
136+ allDeps = Map.union allDirects allIndirects
137+
138+ attempt toConstraint deps =
139+ try (Map.insert pkg C.anything (Map.map toConstraint deps))
140+ in
141+ case
142+ oneOf
143+ ( attempt C.exactly allDeps )
144+ [ attempt C.exactly allDirects
145+ , attempt C.untilNextMinor allDirects
146+ , attempt C.untilNextMajor allDirects
147+ , attempt (\_ -> C.anything) allDirects
148+ ]
149+ of
150+ Solver solver ->
151+ solver (State cache connection registry Map.empty)
152+ (\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
153+ (\_ -> return $ noSolution connection)
154+ (\e -> return $ Err e)
155+
156+
157+toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
158+toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new =
159+ let
160+ d = Map.intersection new (Map.insert pkg V.one direct)
161+ i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
162+ td = Map.intersection new (Map.delete pkg testDirect)
163+ ti = Map.difference new (Map.unions [d,i,td])
164+ in
165+ AppSolution old new (Outline.AppOutline elm srcDirs d i td ti)
166+
167+
168+getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
169+getTransitive constraints solution unvisited visited =
170+ case unvisited of
171+ [] ->
172+ visited
173+
174+ info@(pkg,vsn) : infos ->
175+ if Map.member pkg visited
176+ then getTransitive constraints solution infos visited
177+ else
178+ let
179+ newDeps = _deps (constraints ! info)
180+ newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))
181+ newVisited = Map.insert pkg vsn visited
182+ in
183+ getTransitive constraints solution infos $
184+ getTransitive constraints solution newUnvisited newVisited
185+
186+
187+
188+-- TRY
189+
190+
191+try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
192+try constraints =
193+ exploreGoals (Goals constraints Map.empty)
117
194
118
195
119
196
@@ -149,7 +226,7 @@ addVersion (Goals pending solved) name version =
149 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
226 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
150 return (Goals newPending (Map.insert name version solved))
227 return (Goals newPending (Map.insert name version solved))
151 else
228 else
152− deadend
229+ backtrack
153
230
154
231
155addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
232addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
@@ -158,7 +235,7 @@ addConstraint solved unsolved (name, newConstraint) =
158 Just version ->
235 Just version ->
159 if C.satisfies newConstraint version
236 if C.satisfies newConstraint version
160 then return unsolved
237 then return unsolved
161− else deadend
238+ else backtrack
162
239
163 Nothing ->
240 Nothing ->
164 case Map.lookup name unsolved of
241 case Map.lookup name unsolved of
@@ -168,7 +245,7 @@ addConstraint solved unsolved (name, newConstraint) =
168 Just oldConstraint ->
245 Just oldConstraint ->
169 case C.intersect oldConstraint newConstraint of
246 case C.intersect oldConstraint newConstraint of
170 Nothing ->
247 Nothing ->
171− deadend
248+ backtrack
172
249
173 Just mergedConstraint ->
250 Just mergedConstraint ->
174 if oldConstraint == mergedConstraint
251 if oldConstraint == mergedConstraint
@@ -182,18 +259,15 @@ addConstraint solved unsolved (name, newConstraint) =
182
259
183getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
260getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
184getRelevantVersions name constraint =
261getRelevantVersions name constraint =
185− Solver $ \state@(State _ _ registry _ _) ok err ->
262+ Solver $ \state@(State _ _ registry _) ok back _ ->
186− case Registry.getVersions' name registry of
263+ case Registry.getVersions name registry of
187− Right (Registry.KnownVersions newest previous) ->
264+ Just (Registry.KnownVersions newest previous) ->
188 case filter (C.satisfies constraint) (newest:previous) of
265 case filter (C.satisfies constraint) (newest:previous) of
189− [] ->
266+ [] -> back state
190− err (addProblem (ImpossibleConstraint name constraint) state)
267+ v:vs -> ok state (v,vs) back
191
268
192− v:vs ->
269+ Nothing ->
193− ok state (v,vs) err
270+ back state
194−
195− Left suggestions ->
196− err (addProblem (UnknownPackage suggestions) state)
197
271
198
272
199
273
@@ -201,63 +275,60 @@ getRelevantVersions name constraint =
201
275
202
276
203getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
277getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
204−getConstraints name version =
278+getConstraints pkg vsn =
205− Solver $ \state@(State cache connection registry cDict ps) ok err ->
279+ Solver $ \state@(State cache connection registry cDict) ok back err ->
206− do let key = (name, version)
280+ do let key = (pkg, vsn)
207 case Map.lookup key cDict of
281 case Map.lookup key cDict of
208 Just cs ->
282 Just cs ->
209− ok state cs err
283+ ok state cs back
210
284
211 Nothing ->
285 Nothing ->
212− do result <- getConstraintsHelp cache connection name version
213− case result of
214− Right cs ->
215− ok (State cache connection registry (Map.insert key cs cDict) ps) cs err
286+ do let toNewState cs = State cache connection registry (Map.insert key cs cDict)
216−
217− Left p ->
218− err (State cache connection registry cDict (p:ps))
219−
220−
221−getConstraintsHelp :: Stuff.PackageCache -> Connection -> Pkg.Name -> V.Version -> IO (Either Problem Constraints)
222−getConstraintsHelp cache connection name version =
223− do let home = Stuff.package cache name version
287+ let home = Stuff.package cache pkg vsn
224− let path = home </> "elm.json"
288+ let path = home </> "elm.json"
225− outlineExists <- File.exists path
289+ outlineExists <- File.exists path
226− if outlineExists
290+ if outlineExists
227− then
291+ then
228− do result <- D.fromFile constraintsDecoder path
292+ do bytes <- File.readUtf8 path
229− case result of
293+ case D.fromByteString constraintsDecoder bytes of
230− Right cs ->
294+ Right cs ->
231− case connection of
295+ case connection of
232− Online _ ->
296+ Online _ ->
233− return $ Right cs
297+ ok (toNewState cs) cs back
234−
298+
235− Offline ->
299+ Offline ->
236− do srcExists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")
300+ do srcExists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
237− if srcExists
301+ if srcExists
238− then return $ Right cs
302+ then ok (toNewState cs) cs back
239− else return $ Left (UnavailableOffline name version)
303+ else back state
240−
304+
241− Left _ ->
305+ Left _ ->
242− do File.remove path
306+ do File.remove path
243− return $ Left (BadCacheData name version)
307+ err (Exit.SolverBadCacheData pkg vsn)
244− else
308+ else
245− case connection of
309+ case connection of
246− Offline ->
310+ Offline ->
247− return (Left (UnavailableOffline name version))
311+ back state
248−
312+
249− Online manager ->
313+ Online manager ->
250− Http.get manager (Website.metadata name version "elm.json") [] BadHttp $ \body ->
314+ do result <- Http.get manager (Website.metadata pkg vsn "elm.json") [] id (return . Right)
315+ case result of
316+ Left httpProblem ->
317+ err (Exit.SolverBadHttp httpProblem)
318+
319+ Right body ->
251− case D.fromByteString constraintsDecoder body of
320+ case D.fromByteString constraintsDecoder body of
252− Right cs ->
321+ Right cs ->
253− do Dir.createDirectoryIfMissing True home
322+ do Dir.createDirectoryIfMissing True home
254− File.writeUtf8 path body
323+ File.writeUtf8 path body
255− return $ Right cs
324+ ok (toNewState cs) cs back
256−
325+
257− Left _ ->
326+ Left _ ->
258− return $ Left (BadHttpData name version)
327+ err (Exit.SolverBadHttpData pkg vsn)
259−
328+
260−
329+
330+-- TODO write constraintsDecoder to be a bit faster
331+--
261constraintsDecoder :: D.Decoder () Constraints
332constraintsDecoder :: D.Decoder () Constraints
262constraintsDecoder =
333constraintsDecoder =
263 do outline <- D.mapError (const ()) Outline.decoder
334 do outline <- D.mapError (const ()) Outline.decoder
@@ -270,46 +341,82 @@ constraintsDecoder =
270
341
271
342
272
343
344+-- ENVIRONMENT
345+
346+
347+data Env =
348+ Env Stuff.PackageCache Http.Manager Connection Registry.Registry
349+
350+
351+initEnv :: IO (Either Exit.RegistryProblem Env)
352+initEnv =
353+ do mvar <- newEmptyMVar
354+ _ <- forkIO $ putMVar mvar =<< Http.getManager
355+ cache <- Stuff.getPackageCache
356+ maybeRegistry <- Registry.read cache
357+ manager <- readMVar mvar
358+
359+ case maybeRegistry of
360+ Nothing ->
361+ do eitherRegistry <- Registry.fetch manager cache
362+ case eitherRegistry of
363+ Right latestRegistry ->
364+ return $ Right $ Env cache manager (Online manager) latestRegistry
365+
366+ Left problem ->
367+ return $ Left $ problem
368+
369+ Just cachedRegistry ->
370+ do eitherRegistry <- Registry.update manager cache cachedRegistry
371+ case eitherRegistry of
372+ Right latestRegistry ->
373+ return $ Right $ Env cache manager (Online manager) latestRegistry
374+
375+ Left _ ->
376+ return $ Right $ Env cache manager Offline cachedRegistry
377+
378+
379+
273-- INSTANCES
380-- INSTANCES
274
381
275
382
276instance Functor Solver where
383instance Functor Solver where
277 fmap func (Solver solver) =
384 fmap func (Solver solver) =
278− Solver $ \state ok err ->
385+ Solver $ \state ok back err ->
279 let
386 let
280− okA stateA arg errA = ok stateA (func arg) errA
387+ okA stateA arg backA = ok stateA (func arg) backA
281 in
388 in
282− solver state okA err
389+ solver state okA back err
283
390
284
391
285instance Applicative Solver where
392instance Applicative Solver where
286 pure a =
393 pure a =
287− Solver $ \state ok err -> ok state a err
394+ Solver $ \state ok back _ -> ok state a back
288
395
289 (<*>) (Solver solverFunc) (Solver solverArg) =
396 (<*>) (Solver solverFunc) (Solver solverArg) =
290− Solver $ \state ok err ->
397+ Solver $ \state ok back err ->
291 let
398 let
292− okF stateF func errF =
399+ okF stateF func backF =
293 let
400 let
294− okA stateA arg errA = ok stateA (func arg) errA
401+ okA stateA arg backA = ok stateA (func arg) backA
295 in
402 in
296− solverArg stateF okA errF
403+ solverArg stateF okA backF err
297 in
404 in
298− solverFunc state okF err
405+ solverFunc state okF back err
299
406
300
407
301instance Monad Solver where
408instance Monad Solver where
302 return a =
409 return a =
303− Solver $ \state ok err -> ok state a err
410+ Solver $ \state ok back _ -> ok state a back
304
411
305 (>>=) (Solver solverA) callback =
412 (>>=) (Solver solverA) callback =
306− Solver $ \state ok err ->
413+ Solver $ \state ok back err ->
307 let
414 let
308− okA stateA a errA =
415+ okA stateA a backA =
309 case callback a of
416 case callback a of
310− Solver solverB -> solverB stateA ok errA
417+ Solver solverB -> solverB stateA ok backA err
311 in
418 in
312− solverA state okA err
419+ solverA state okA back err
313
420
314
421
315oneOf :: Solver a -> [Solver a] -> Solver a
422oneOf :: Solver a -> [Solver a] -> Solver a
@@ -319,19 +426,17 @@ oneOf solver@(Solver solverHead) solvers =
319 solver
426 solver
320
427
321 s:ss ->
428 s:ss ->
322− Solver $ \state0 ok err ->
429+ Solver $ \state0 ok back err ->
323− solverHead state0 ok $ \state1 ->
430+ let
431+ tryTail state1 =
324− let
432+ let
325− (Solver solverTail) = oneOf s ss
433+ (Solver solverTail) = oneOf s ss
326− in
434+ in
327− solverTail state1 ok err
435+ solverTail state1 ok back err
328−
436+ in
329−
437+ solverHead state0 ok tryTail err
438+
439+
330−deadend :: Solver a
440+backtrack :: Solver a
331−deadend =
441+backtrack =
332− Solver $ \state _ err -> err state
442+ Solver $ \state _ back _ -> back state
333−
334−
335−addProblem :: Problem -> State -> State
336−addProblem problem (State cache registry cDict maybeManager problems) =
337− State cache registry cDict maybeManager (problem:problems)