@@ -1,88 +1,151 @@
1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
12module Deps.Solver
23 ( Solver
3− , run
4+ , Details(..)
5+ , Connection(..)
46 , solve
57 )
68 where
79
810
9−import Control.Monad (foldM, guard, mzero, msum)
10−import Control.Monad.Logic (LogicT, runLogicT, lift)
11−import qualified Data.List as List
11+import Control.Monad (foldM)
1212import qualified Data.Map as Map
13−import Data.Map (Map)
13+import qualified System.Directory as Dir
1414
15−import Deps.Explorer (Explorer)
16−import qualified Deps.Explorer as Explorer
15+import qualified Deps.Registry as Registry
16+import qualified Deps.Website as Website
1717import qualified Elm.Constraint as C
1818import qualified Elm.Package as Pkg
19+import qualified Elm.Outline as Outline
1920import qualified Elm.Version as V
21+import qualified File
22+import qualified Http
23+import qualified Json.Decode as D
24+import qualified Stuff
2025
2126
2227
23−-- SOLVE
28+-- SOLVER
2429
2530
26−solve :: Map Pkg.Name C.Constraint -> Solver (Map Pkg.Name V.Version)
27−solve cons =
28− mkSolver (State Map.empty cons)
31+newtype Solver a =
32+ Solver
33+ (
34+ forall b.
35+ State
36+ -> (State -> a -> (State -> IO b) -> IO b)
37+ -> (State -> IO b)
38+ -> IO b
39+ )
2940
3041
31−type Solver a =
32− LogicT Explorer a
42+data State =
43+ State
44+ { _cache :: Stuff.PackageCache
45+ , _internet :: Connection
46+ , _registry :: Registry.Registry
47+ , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
48+ , _problems :: [Problem]
49+ }
3350
3451
35−run :: Solver a -> Explorer (Maybe a)
36−run solver =
37− runLogicT solver (const . return . Just) (return Nothing)
52+data Constraints =
53+ Constraints
54+ { _elm :: C.Constraint
55+ , _deps :: Map.Map Pkg.Name C.Constraint
56+ }
3857
3958
59+data Connection
60+ = Online Http.Manager
61+ | Offline
4062
41−-- SOLVER
4263
64+data Problem
65+ = BadCacheData Pkg.Name V.Version
66+ | BadHttpData Pkg.Name V.Version
67+ | BadHttp Http.Error
68+ | UnknownPackage [Pkg.Name]
69+ | ImpossibleConstraint Pkg.Name C.Constraint
70+ | UnavailableOffline Pkg.Name V.Version
71+
72+
73+
74+-- SOLVE
75+
76+
77+data Details =
78+ Details V.Version [Pkg.Name]
4379
44−data State =
45− State
46− { _solution :: Map Pkg.Name V.Version
47− , _unsolved :: Map Pkg.Name C.Constraint
48− }
4980
81+solve :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
82+solve cache connection registry constraints =
83+ let
84+ (Solver solver) = exploreGoals (Goals constraints Map.empty)
85+ in
86+ solver (State cache connection registry Map.empty [])
87+ (\(State _ _ _ cs _) vs _ -> return $ Right $ getDetails vs cs)
88+ (\(State _ _ _ _ ps) -> return $ Left ps)
89+
90+
91+getDetails :: Map.Map Pkg.Name V.Version -> Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name Details
92+getDetails solution constraints =
93+ Map.mapWithKey (getDetailsHelp constraints) solution
94+
95+
96+getDetailsHelp :: Map.Map (Pkg.Name, V.Version) Constraints -> Pkg.Name -> V.Version -> Details
97+getDetailsHelp constraints name vsn =
98+ case Map.lookup (name, vsn) constraints of
99+ Just (Constraints _ deps) ->
100+ Details vsn (Map.keys deps)
50101
51−mkSolver :: State -> Solver (Map Pkg.Name V.Version)
52−mkSolver (State solution unsolved) =
53− case Map.minViewWithKey unsolved of
54102 Nothing ->
55− return solution
103+ error "compiler bug in Deps.Solver manifesting in getDetailsHelp"
104+
56105
57− Just ((name, constraint), otherUnsolved) ->
58− do allVersions <- lift $ Explorer.getVersions name
59− let versions =
60− reverse $ List.sort $
61− filter (C.satisfies constraint) allVersions
62106
63− let state1 = State solution otherUnsolved
64− state2 <- msum (map (addVersion state1 name) versions)
65− mkSolver state2
107+-- EXPLORE GOALS
66108
67109
68−addVersion :: State -> Pkg.Name -> V.Version -> Solver State
69−addVersion (State solution unsolved) name version =
70− do (Explorer.Info elm cons) <-
71− lift $ Explorer.getConstraints name version
110+data Goals =
111+ Goals
112+ { _pending :: Map.Map Pkg.Name C.Constraint
113+ , _solved :: Map.Map Pkg.Name V.Version
114+ }
115+
116+
117+exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version)
118+exploreGoals (Goals pending solved) =
119+ case Map.minViewWithKey pending of
120+ Nothing ->
121+ return solved
72122
73− guard (C.goodElm elm)
74− newUnsolved <- foldM (addConstraint solution) unsolved (Map.toList cons)
75− return (State (Map.insert name version solution) newUnsolved)
123+ Just ((name, constraint), otherPending) ->
124+ do let goals1 = Goals otherPending solved
125+ let addVsn = addVersion goals1 name
126+ (v,vs) <- getRelevantVersions name constraint
127+ goals2 <- oneOf (addVsn v) (map addVsn vs)
128+ exploreGoals goals2
76129
77130
78−addConstraint :: Map Pkg.Name V.Version -> Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map Pkg.Name C.Constraint)
79−addConstraint solution unsolved (name, newConstraint) =
80− case Map.lookup name solution of
131+addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals
132+addVersion (Goals pending solved) name version =
133+ do (Constraints elm deps) <- getConstraints name version
134+ if C.goodElm elm
135+ then
136+ do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
137+ return (Goals newPending (Map.insert name version solved))
138+ else
139+ deadend
140+
141+
142+addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
143+addConstraint solved unsolved (name, newConstraint) =
144+ case Map.lookup name solved of
81145 Just version ->
82− if C.satisfies newConstraint version then
83− return unsolved
84− else
85− mzero
146+ if C.satisfies newConstraint version
147+ then return unsolved
148+ else deadend
86149
87150 Nothing ->
88151 case Map.lookup name unsolved of
@@ -92,11 +155,168 @@ addConstraint solution unsolved (name, newConstraint) =
92155 Just oldConstraint ->
93156 case C.intersect oldConstraint newConstraint of
94157 Nothing ->
95− mzero
158+ deadend
96159
97160 Just mergedConstraint ->
98− if oldConstraint == mergedConstraint then
99− return unsolved
100− else
101− return (Map.insert name mergedConstraint unsolved)
161+ if oldConstraint == mergedConstraint
162+ then return unsolved
163+ else return (Map.insert name mergedConstraint unsolved)
164+
165+
166+
167+-- GET RELEVANT VERSIONS
168+
169+
170+getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
171+getRelevantVersions name constraint =
172+ Solver $ \state@(State _ _ registry _ _) ok err ->
173+ case Registry.getVersions' name registry of
174+ Right (Registry.KnownVersions newest previous) ->
175+ case filter (C.satisfies constraint) (newest:previous) of
176+ [] ->
177+ err (addProblem (ImpossibleConstraint name constraint) state)
178+
179+ v:vs ->
180+ ok state (v,vs) err
181+
182+ Left suggestions ->
183+ err (addProblem (UnknownPackage suggestions) state)
184+
185+
186+
187+-- GET CONSTRAINTS
188+
189+
190+getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
191+getConstraints name version =
192+ Solver $ \state@(State cache connection registry cDict ps) ok err ->
193+ do let key = (name, version)
194+ case Map.lookup key cDict of
195+ Just cs ->
196+ ok state cs err
197+
198+ Nothing ->
199+ do result <- getConstraintsHelp cache connection name version
200+ case result of
201+ Right cs ->
202+ ok (State cache connection registry (Map.insert key cs cDict) ps) cs err
203+
204+ Left p ->
205+ err (State cache connection registry cDict (p:ps))
206+
207+
208+getConstraintsHelp :: Stuff.PackageCache -> Connection -> Pkg.Name -> V.Version -> IO (Either Problem Constraints)
209+getConstraintsHelp cache connection name version =
210+ do let path = Stuff.metadata cache name version "elm.json"
211+ outlineExists <- File.exists path
212+ if outlineExists
213+ then
214+ do result <- D.fromFile constraintsDecoder path
215+ case result of
216+ Right cs ->
217+ case connection of
218+ Online _ ->
219+ return $ Right cs
220+
221+ Offline ->
222+ do srcExists <- Dir.doesDirectoryExist (Stuff.metadata cache name version "src")
223+ if srcExists
224+ then return $ Right cs
225+ else return $ Left (UnavailableOffline name version)
226+
227+ Left _ ->
228+ do File.remove path
229+ return $ Left (BadCacheData name version)
230+ else
231+ case connection of
232+ Offline ->
233+ return (Left (UnavailableOffline name version))
234+
235+ Online manager ->
236+ Http.post manager (Website.metadata name version "elm.json") [] BadHttp $ \body ->
237+ case D.fromByteString constraintsDecoder body of
238+ Right cs ->
239+ do File.writeUtf8 path body
240+ return $ Right cs
241+
242+ Left _ ->
243+ return $ Left (BadHttpData name version)
244+
245+
246+constraintsDecoder :: D.Decoder () Constraints
247+constraintsDecoder =
248+ do outline <- D.mapError (const ()) Outline.decoder
249+ case outline of
250+ Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ elmConstraint) ->
251+ return (Constraints elmConstraint deps)
252+
253+ Outline.App _ ->
254+ D.failure ()
255+
256+
257+
258+-- INSTANCES
259+
260+
261+instance Functor Solver where
262+ fmap func (Solver solver) =
263+ Solver $ \state ok err ->
264+ let
265+ okA stateA arg errA = ok stateA (func arg) errA
266+ in
267+ solver state okA err
268+
269+
270+instance Applicative Solver where
271+ pure a =
272+ Solver $ \state ok err -> ok state a err
273+
274+ (<*>) (Solver solverFunc) (Solver solverArg) =
275+ Solver $ \state ok err ->
276+ let
277+ okF stateF func errF =
278+ let
279+ okA stateA arg errA = ok stateA (func arg) errA
280+ in
281+ solverArg stateF okA errF
282+ in
283+ solverFunc state okF err
284+
285+
286+instance Monad Solver where
287+ return a =
288+ Solver $ \state ok err -> ok state a err
289+
290+ (>>=) (Solver solverA) callback =
291+ Solver $ \state ok err ->
292+ let
293+ okA stateA a errA =
294+ case callback a of
295+ Solver solverB -> solverB stateA ok errA
296+ in
297+ solverA state okA err
298+
299+
300+oneOf :: Solver a -> [Solver a] -> Solver a
301+oneOf solver@(Solver solverHead) solvers =
302+ case solvers of
303+ [] ->
304+ solver
305+
306+ s:ss ->
307+ Solver $ \state0 ok err ->
308+ solverHead state0 ok $ \state1 ->
309+ let
310+ (Solver solverTail) = oneOf s ss
311+ in
312+ solverTail state1 ok err
313+
314+
315+deadend :: Solver a
316+deadend =
317+ Solver $ \state _ err -> err state
318+
102319
320+addProblem :: Problem -> State -> State
321+addProblem problem (State cache registry cDict maybeManager problems) =
322+ State cache registry cDict maybeManager (problem:problems)