@@ -1,14 +1,25 @@
11{-# LANGUAGE OverloadedStrings, Rank2Types #-}
22module Deps.Solver
3− ( online
4− , offline
3+ ( Solver
4+ , Result(..)
5+ , Connection(..)
6+ --
57 , Details(..)
8+ , verify
9+ --
10+ , AppSolution(..)
11+ , addToApp
12+ --
13+ , Env(..)
14+ , initEnv
615 )
716 where
817
918
1019import Control.Monad (foldM)
20+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
1121import qualified Data.Map as Map
22+import Data.Map ((!))
1223import qualified System.Directory as Dir
1324import System.FilePath ((</>))
1425
@@ -21,52 +32,11 @@ import qualified Elm.Version as V
2132import qualified File
2233import qualified Http
2334import qualified Json.Decode as D
35+import qualified Reporting.Exit as Exit
2436import qualified Stuff
2537
2638
2739
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−
7040-- SOLVER
7141
7242
@@ -77,21 +47,17 @@ newtype Solver a =
7747 State
7848 -> (State -> a -> (State -> IO b) -> IO b)
7949 -> (State -> IO b)
50+ -> (Exit.Solver -> IO b)
8051 -> IO b
8152 )
8253
8354
84−
85−-- STATE
86−
87−
8855data State =
8956 State
9057 { _cache :: Stuff.PackageCache
91− , _internet :: Connection
58+ , _connection :: Connection
9259 , _registry :: Registry.Registry
9360 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
94− , _problems :: [Problem]
9561 }
9662
9763
@@ -107,13 +73,124 @@ data Connection
10773 | Offline
10874
10975
110−data Problem
111− = BadCacheData Pkg.Name V.Version
112− | BadHttpData Pkg.Name V.Version
113− | BadHttp Http.Error
114− | UnknownPackage [Pkg.Name]
115− | ImpossibleConstraint Pkg.Name C.Constraint
116− | UnavailableOffline Pkg.Name V.Version
76+
77+-- RESULT
78+
79+
80+data Result a
81+ = Ok a
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)
117194
118195
119196
@@ -149,7 +226,7 @@ addVersion (Goals pending solved) name version =
149226 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
150227 return (Goals newPending (Map.insert name version solved))
151228 else
152− deadend
229+ backtrack
153230
154231
155232addConstraint :: 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) =
158235 Just version ->
159236 if C.satisfies newConstraint version
160237 then return unsolved
161− else deadend
238+ else backtrack
162239
163240 Nothing ->
164241 case Map.lookup name unsolved of
@@ -168,7 +245,7 @@ addConstraint solved unsolved (name, newConstraint) =
168245 Just oldConstraint ->
169246 case C.intersect oldConstraint newConstraint of
170247 Nothing ->
171− deadend
248+ backtrack
172249
173250 Just mergedConstraint ->
174251 if oldConstraint == mergedConstraint
@@ -182,18 +259,15 @@ addConstraint solved unsolved (name, newConstraint) =
182259
183260getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
184261getRelevantVersions name constraint =
185− Solver $ \state@(State _ _ registry _ _) ok err ->
186− case Registry.getVersions' name registry of
187− Right (Registry.KnownVersions newest previous) ->
262+ Solver $ \state@(State _ _ registry _) ok back _ ->
263+ case Registry.getVersions name registry of
264+ Just (Registry.KnownVersions newest previous) ->
188265 case filter (C.satisfies constraint) (newest:previous) of
189− [] ->
190− err (addProblem (ImpossibleConstraint name constraint) state)
266+ [] -> back state
267+ v:vs -> ok state (v,vs) back
191268
192− v:vs ->
193− ok state (v,vs) err
194−
195− Left suggestions ->
196− err (addProblem (UnknownPackage suggestions) state)
269+ Nothing ->
270+ back state
197271
198272
199273
@@ -201,63 +275,60 @@ getRelevantVersions name constraint =
201275
202276
203277getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
204−getConstraints name version =
205− Solver $ \state@(State cache connection registry cDict ps) ok err ->
206− do let key = (name, version)
278+getConstraints pkg vsn =
279+ Solver $ \state@(State cache connection registry cDict) ok back err ->
280+ do let key = (pkg, vsn)
207281 case Map.lookup key cDict of
208282 Just cs ->
209− ok state cs err
283+ ok state cs back
210284
211285 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
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
224− let path = home </> "elm.json"
225− outlineExists <- File.exists path
226− if outlineExists
227− then
228− do result <- D.fromFile constraintsDecoder path
229− case result of
230− Right cs ->
231− case connection of
232− Online _ ->
233− return $ Right cs
234−
235− Offline ->
236− do srcExists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")
237− if srcExists
238− then return $ Right cs
239− else return $ Left (UnavailableOffline name version)
240−
241− Left _ ->
242− do File.remove path
243− return $ Left (BadCacheData name version)
244− else
245− case connection of
246− Offline ->
247− return (Left (UnavailableOffline name version))
248−
249− Online manager ->
250− Http.get manager (Website.metadata name version "elm.json") [] BadHttp $ \body ->
251− case D.fromByteString constraintsDecoder body of
252− Right cs ->
253− do Dir.createDirectoryIfMissing True home
254− File.writeUtf8 path body
255− return $ Right cs
256−
257− Left _ ->
258− return $ Left (BadHttpData name version)
259−
260−
286+ do let toNewState cs = State cache connection registry (Map.insert key cs cDict)
287+ let home = Stuff.package cache pkg vsn
288+ let path = home </> "elm.json"
289+ outlineExists <- File.exists path
290+ if outlineExists
291+ then
292+ do bytes <- File.readUtf8 path
293+ case D.fromByteString constraintsDecoder bytes of
294+ Right cs ->
295+ case connection of
296+ Online _ ->
297+ ok (toNewState cs) cs back
298+
299+ Offline ->
300+ do srcExists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
301+ if srcExists
302+ then ok (toNewState cs) cs back
303+ else back state
304+
305+ Left _ ->
306+ do File.remove path
307+ err (Exit.SolverBadCacheData pkg vsn)
308+ else
309+ case connection of
310+ Offline ->
311+ back state
312+
313+ Online manager ->
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 ->
320+ case D.fromByteString constraintsDecoder body of
321+ Right cs ->
322+ do Dir.createDirectoryIfMissing True home
323+ File.writeUtf8 path body
324+ ok (toNewState cs) cs back
325+
326+ Left _ ->
327+ err (Exit.SolverBadHttpData pkg vsn)
328+
329+
330+-- TODO write constraintsDecoder to be a bit faster
331+--
261332constraintsDecoder :: D.Decoder () Constraints
262333constraintsDecoder =
263334 do outline <- D.mapError (const ()) Outline.decoder
@@ -270,46 +341,82 @@ constraintsDecoder =
270341
271342
272343
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+
273380-- INSTANCES
274381
275382
276383instance Functor Solver where
277384 fmap func (Solver solver) =
278− Solver $ \state ok err ->
385+ Solver $ \state ok back err ->
279386 let
280− okA stateA arg errA = ok stateA (func arg) errA
387+ okA stateA arg backA = ok stateA (func arg) backA
281388 in
282− solver state okA err
389+ solver state okA back err
283390
284391
285392instance Applicative Solver where
286393 pure a =
287− Solver $ \state ok err -> ok state a err
394+ Solver $ \state ok back _ -> ok state a back
288395
289396 (<*>) (Solver solverFunc) (Solver solverArg) =
290− Solver $ \state ok err ->
397+ Solver $ \state ok back err ->
291398 let
292− okF stateF func errF =
399+ okF stateF func backF =
293400 let
294− okA stateA arg errA = ok stateA (func arg) errA
401+ okA stateA arg backA = ok stateA (func arg) backA
295402 in
296− solverArg stateF okA errF
403+ solverArg stateF okA backF err
297404 in
298− solverFunc state okF err
405+ solverFunc state okF back err
299406
300407
301408instance Monad Solver where
302409 return a =
303− Solver $ \state ok err -> ok state a err
410+ Solver $ \state ok back _ -> ok state a back
304411
305412 (>>=) (Solver solverA) callback =
306− Solver $ \state ok err ->
413+ Solver $ \state ok back err ->
307414 let
308− okA stateA a errA =
415+ okA stateA a backA =
309416 case callback a of
310− Solver solverB -> solverB stateA ok errA
417+ Solver solverB -> solverB stateA ok backA err
311418 in
312− solverA state okA err
419+ solverA state okA back err
313420
314421
315422oneOf :: Solver a -> [Solver a] -> Solver a
@@ -319,19 +426,17 @@ oneOf solver@(Solver solverHead) solvers =
319426 solver
320427
321428 s:ss ->
322− Solver $ \state0 ok err ->
323− solverHead state0 ok $ \state1 ->
324− let
325− (Solver solverTail) = oneOf s ss
326− in
327− solverTail state1 ok err
328−
329−
330−deadend :: Solver a
331−deadend =
332− Solver $ \state _ err -> err 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)
429+ Solver $ \state0 ok back err ->
430+ let
431+ tryTail state1 =
432+ let
433+ (Solver solverTail) = oneOf s ss
434+ in
435+ solverTail state1 ok back err
436+ in
437+ solverHead state0 ok tryTail err
438+
439+
440+backtrack :: Solver a
441+backtrack =
442+ Solver $ \state _ back _ -> back state