git.iko.soy/elk
on f4401ac help sign in
elk/builder/src/Deps/Solver.hs
442 lines 13 kB history raw
1{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2module Deps.Solver
3 ( Solver
4 , Result(..)
5 , Connection(..)
6 --
7 , Details(..)
8 , verify
9 --
10 , AppSolution(..)
11 , addToApp
12 --
13 , Env(..)
14 , initEnv
15 )
16 where
19import Control.Monad (foldM)
20import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
21import qualified Data.Map as Map
22import Data.Map ((!))
23import qualified System.Directory as Dir
24import System.FilePath ((</>))
26import qualified Deps.Registry as Registry
27import qualified Deps.Website as Website
28import qualified Elm.Constraint as C
29import qualified Elm.Package as Pkg
30import qualified Elm.Outline as Outline
31import qualified Elm.Version as V
32import qualified File
33import qualified Http
34import qualified Json.Decode as D
35import qualified Reporting.Exit as Exit
36import qualified Stuff
40-- SOLVER
43newtype Solver a =
44 Solver
45 (
46 forall b.
47 State
48 -> (State -> a -> (State -> IO b) -> IO b)
49 -> (State -> IO b)
50 -> (Exit.Solver -> IO b)
51 -> IO b
52 )
55data State =
56 State
57 { _cache :: Stuff.PackageCache
58 , _connection :: Connection
59 , _registry :: Registry.Registry
60 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
61 }
64data Constraints =
65 Constraints
66 { _elm :: C.Constraint
67 , _deps :: Map.Map Pkg.Name C.Constraint
68 }
71data Connection
72 = Online Http.Manager
73 | Offline
77-- RESULT
80data Result a
81 = Ok a
82 | NoSolution
83 | NoOfflineSolution
84 | Err Exit.Solver
88-- VERIFY -- used by Elm.Details
91data Details =
92 Details V.Version (Map.Map Pkg.Name C.Constraint)
95verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96verify 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)
105addDeps :: State -> Pkg.Name -> V.Version -> Details
106addDeps (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"
112noSolution :: Connection -> Result a
113noSolution connection =
114 case connection of
115 Online _ -> NoSolution
116 Offline -> NoOfflineSolution
120-- ADD TO APP - used in Install
123data AppSolution =
124 AppSolution
125 { _old :: Map.Map Pkg.Name V.Version
126 , _new :: Map.Map Pkg.Name V.Version
127 , _app :: Outline.AppOutline
128 }
131addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
132addToApp 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
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)
157toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
158toApp (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)
168getTransitive :: 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
169getTransitive constraints solution unvisited visited =
170 case unvisited of
171 [] ->
172 visited
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
188-- TRY
191try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
192try constraints =
193 exploreGoals (Goals constraints Map.empty)
197-- EXPLORE GOALS
200data Goals =
201 Goals
202 { _pending :: Map.Map Pkg.Name C.Constraint
203 , _solved :: Map.Map Pkg.Name V.Version
204 }
207exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version)
208exploreGoals (Goals pending solved) =
209 case Map.minViewWithKey pending of
210 Nothing ->
211 return solved
213 Just ((name, constraint), otherPending) ->
214 do let goals1 = Goals otherPending solved
215 let addVsn = addVersion goals1 name
216 (v,vs) <- getRelevantVersions name constraint
217 goals2 <- oneOf (addVsn v) (map addVsn vs)
218 exploreGoals goals2
221addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals
222addVersion (Goals pending solved) name version =
223 do (Constraints elm deps) <- getConstraints name version
224 if C.goodElm elm
225 then
226 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
227 return (Goals newPending (Map.insert name version solved))
228 else
229 backtrack
232addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
233addConstraint solved unsolved (name, newConstraint) =
234 case Map.lookup name solved of
235 Just version ->
236 if C.satisfies newConstraint version
237 then return unsolved
238 else backtrack
240 Nothing ->
241 case Map.lookup name unsolved of
242 Nothing ->
243 return $ Map.insert name newConstraint unsolved
245 Just oldConstraint ->
246 case C.intersect oldConstraint newConstraint of
247 Nothing ->
248 backtrack
250 Just mergedConstraint ->
251 if oldConstraint == mergedConstraint
252 then return unsolved
253 else return (Map.insert name mergedConstraint unsolved)
257-- GET RELEVANT VERSIONS
260getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
261getRelevantVersions name constraint =
262 Solver $ \state@(State _ _ registry _) ok back _ ->
263 case Registry.getVersions name registry of
264 Just (Registry.KnownVersions newest previous) ->
265 case filter (C.satisfies constraint) (newest:previous) of
266 [] -> back state
267 v:vs -> ok state (v,vs) back
269 Nothing ->
270 back state
274-- GET CONSTRAINTS
277getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
278getConstraints pkg vsn =
279 Solver $ \state@(State cache connection registry cDict) ok back err ->
280 do let key = (pkg, vsn)
281 case Map.lookup key cDict of
282 Just cs ->
283 ok state cs back
285 Nothing ->
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
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
305 Left _ ->
306 do File.remove path
307 err (Exit.SolverBadCacheData pkg vsn)
308 else
309 case connection of
310 Offline ->
311 back state
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)
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
326 Left _ ->
327 err (Exit.SolverBadHttpData pkg vsn)
330-- TODO write constraintsDecoder to be a bit faster
331--
332constraintsDecoder :: D.Decoder () Constraints
333constraintsDecoder =
334 do outline <- D.mapError (const ()) Outline.decoder
335 case outline of
336 Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ elmConstraint) ->
337 return (Constraints elmConstraint deps)
339 Outline.App _ ->
340 D.failure ()
344-- ENVIRONMENT
347data Env =
348 Env Stuff.PackageCache Http.Manager Connection Registry.Registry
351initEnv :: IO (Either Exit.RegistryProblem Env)
352initEnv =
353 do mvar <- newEmptyMVar
354 _ <- forkIO $ putMVar mvar =<< Http.getManager
355 cache <- Stuff.getPackageCache
356 maybeRegistry <- Registry.read cache
357 manager <- readMVar mvar
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
366 Left problem ->
367 return $ Left $ problem
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
375 Left _ ->
376 return $ Right $ Env cache manager Offline cachedRegistry
380-- INSTANCES
383instance Functor Solver where
384 fmap func (Solver solver) =
385 Solver $ \state ok back err ->
386 let
387 okA stateA arg backA = ok stateA (func arg) backA
388 in
389 solver state okA back err
392instance Applicative Solver where
393 pure a =
394 Solver $ \state ok back _ -> ok state a back
396 (<*>) (Solver solverFunc) (Solver solverArg) =
397 Solver $ \state ok back err ->
398 let
399 okF stateF func backF =
400 let
401 okA stateA arg backA = ok stateA (func arg) backA
402 in
403 solverArg stateF okA backF err
404 in
405 solverFunc state okF back err
408instance Monad Solver where
409 return a =
410 Solver $ \state ok back _ -> ok state a back
412 (>>=) (Solver solverA) callback =
413 Solver $ \state ok back err ->
414 let
415 okA stateA a backA =
416 case callback a of
417 Solver solverB -> solverB stateA ok backA err
418 in
419 solverA state okA back err
422oneOf :: Solver a -> [Solver a] -> Solver a
423oneOf solver@(Solver solverHead) solvers =
424 case solvers of
425 [] ->
426 solver
428 s:ss ->
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
440backtrack :: Solver a
441backtrack =
442 Solver $ \state _ back _ -> back state