git.iko.soy/elk
on master help sign in
Collapse Deps.Explorer into Deps.Solver with new CPS implementation
08cb6f7Evan Czaplicki
builder/src/Deps/Explorer.hsdeleted−116
compare with master
unifiedsplit
@@ -1,116 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Deps.Explorer
3− ( Explorer
4− , Metadata
5− , Info(..)
6− , run
7− , exists
8− , getVersions
9− , getConstraints
10− )
11− where
12−
13−{-| It is expensive to load ALL package metadata. You would need to:
14−
15− 1. Know all the packages and all their versions.
16− 2. Download or read the elm.json file for each version.
17−
18−The goal of this module is to only pay for (1) and pay for (2) as needed.
19−-}
20−
21−
22−import Control.Monad.Except (liftIO, lift, throwError)
23−import Control.Monad.State (StateT, evalStateT, gets, modify)
24−import qualified Data.Map as Map
25−
26−import qualified Deps.Cache as Cache
27−import qualified Elm.Constraint as C
28−import qualified Elm.Package as Pkg
29−import qualified Elm.PerUserCache as PerUserCache
30−import qualified Elm.Project.Json as Project
31−import qualified Elm.Version as V
32−import qualified Reporting.Exit as Exit
33−import qualified Reporting.Exit.Deps as E
34−import qualified Reporting.Task as Task
35−
36−
37−
38−-- EXPLORER
39−
40−
41−type Explorer =
42− StateT Metadata Task.Task
43−
44−
45−data Metadata =
46− Metadata
47− { _registry :: Cache.PackageRegistry
48− , _info :: Map.Map (Pkg.Name, V.Version) Info
49− }
50−
51−
52−data Info =
53− Info
54− { _elm :: C.Constraint
55− , _pkgs :: Map.Map Pkg.Name C.Constraint
56− }
57−
58−
59−run :: Cache.PackageRegistry -> Explorer a -> Task.Task a
60−run registry explorer =
61− evalStateT explorer (Metadata registry Map.empty)
62−
63−
64−
65−-- EXISTS
66−
67−
68−exists :: Pkg.Name -> Explorer ()
69−exists name =
70− do registry <- gets _registry
71− case Cache.getVersions name registry of
72− Right _ ->
73− return ()
74−
75− Left suggestions ->
76− throwError (Exit.Deps (E.PackageNotFound name suggestions))
77−
78−
79−
80−-- VERSIONS
81−
82−
83−getVersions :: Pkg.Name -> Explorer [V.Version]
84−getVersions name =
85− do registry <- gets _registry
86− case Cache.getVersions name registry of
87− Right versions ->
88− return versions
89−
90− Left _suggestions ->
91− do elmHome <- liftIO PerUserCache.getElmHome
92− throwError (Exit.Deps (E.CorruptVersionCache elmHome name))
93−
94−
95−
96−-- CONSTRAINTS
97−
98−
99−getConstraints :: Pkg.Name -> V.Version -> Explorer Info
100−getConstraints name version =
101− do allInfo <- gets _info
102− case Map.lookup (name, version) allInfo of
103− Just info ->
104− return info
105−
106− Nothing ->
107− do pkgInfo <- lift $ Cache.getElmJson name version
108−
109− let elm = Project._pkg_elm_version pkgInfo
110− let pkgs = Project._pkg_deps pkgInfo
111− let info = Info elm pkgs
112−
113− modify $ \(Metadata vsns infos) ->
114− Metadata vsns $ Map.insert (name, version) info infos
115−
116− return info
builder/src/Deps/Solver.hs+273−53
@@ -1,88 +1,151 @@
1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
1module Deps.Solver
2module Deps.Solver
2 ( Solver
3 ( Solver
3− , run
4+ , Details(..)
5+ , Connection(..)
4 , solve
6 , solve
5 )
7 )
6 where
8 where
7
9
8
10
9−import Control.Monad (foldM, guard, mzero, msum)
11+import Control.Monad (foldM)
10−import Control.Monad.Logic (LogicT, runLogicT, lift)
11−import qualified Data.List as List
12import qualified Data.Map as Map
12import qualified Data.Map as Map
13−import Data.Map (Map)
13+import qualified System.Directory as Dir
14
14
15−import Deps.Explorer (Explorer)
15+import qualified Deps.Registry as Registry
16−import qualified Deps.Explorer as Explorer
16+import qualified Deps.Website as Website
17import qualified Elm.Constraint as C
17import qualified Elm.Constraint as C
18import qualified Elm.Package as Pkg
18import qualified Elm.Package as Pkg
19+import qualified Elm.Outline as Outline
19import qualified Elm.Version as V
20import qualified Elm.Version as V
21+import qualified File
22+import qualified Http
23+import qualified Json.Decode as D
24+import qualified Stuff
20
25
21
26
22
27
23−-- SOLVE
28+-- SOLVER
24
29
25
30
26−solve :: Map Pkg.Name C.Constraint -> Solver (Map Pkg.Name V.Version)
31+newtype Solver a =
27−solve cons =
32+ Solver
28− mkSolver (State Map.empty cons)
33+ (
34+ forall b.
35+ State
36+ -> (State -> a -> (State -> IO b) -> IO b)
37+ -> (State -> IO b)
38+ -> IO b
39+ )
29
40
30
41
31−type Solver a =
42+data State =
32− LogicT Explorer a
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+ }
33
50
34
51
35−run :: Solver a -> Explorer (Maybe a)
52+data Constraints =
36−run solver =
53+ Constraints
37− runLogicT solver (const . return . Just) (return Nothing)
54+ { _elm :: C.Constraint
55+ , _deps :: Map.Map Pkg.Name C.Constraint
56+ }
38
57
39
58
59+data Connection
60+ = Online Http.Manager
61+ | Offline
40
62
41−-- SOLVER
42
63
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]
43
79
44−data State =
45− State
46− { _solution :: Map Pkg.Name V.Version
47− , _unsolved :: Map Pkg.Name C.Constraint
48− }
49
80
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)
50
101
51−mkSolver :: State -> Solver (Map Pkg.Name V.Version)
52−mkSolver (State solution unsolved) =
53− case Map.minViewWithKey unsolved of
54 Nothing ->
102 Nothing ->
55− return solution
103+ error "compiler bug in Deps.Solver manifesting in getDetailsHelp"
104+
56
105
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
62
106
63− let state1 = State solution otherUnsolved
107+-- EXPLORE GOALS
64− state2 <- msum (map (addVersion state1 name) versions)
65− mkSolver state2
66
108
67
109
110+data Goals =
111+ Goals
112+ { _pending :: Map.Map Pkg.Name C.Constraint
68−addVersion :: State -> Pkg.Name -> V.Version -> Solver State
113+ , _solved :: Map.Map Pkg.Name V.Version
69−addVersion (State solution unsolved) name version =
114+ }
70− do (Explorer.Info elm cons) <-
115+
71− lift $ Explorer.getConstraints name version
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
72
122
73− guard (C.goodElm elm)
123+ Just ((name, constraint), otherPending) ->
74− newUnsolved <- foldM (addConstraint solution) unsolved (Map.toList cons)
124+ do let goals1 = Goals otherPending solved
75− return (State (Map.insert name version solution) newUnsolved)
125+ let addVsn = addVersion goals1 name
126+ (v,vs) <- getRelevantVersions name constraint
127+ goals2 <- oneOf (addVsn v) (map addVsn vs)
128+ exploreGoals goals2
76
129
77
130
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+
78−addConstraint :: Map Pkg.Name V.Version -> Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map Pkg.Name C.Constraint)
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)
79−addConstraint solution unsolved (name, newConstraint) =
143+addConstraint solved unsolved (name, newConstraint) =
80− case Map.lookup name solution of
144+ case Map.lookup name solved of
81 Just version ->
145 Just version ->
82− if C.satisfies newConstraint version then
146+ if C.satisfies newConstraint version
83− return unsolved
147+ then return unsolved
84− else
148+ else deadend
85− mzero
86
149
87 Nothing ->
150 Nothing ->
88 case Map.lookup name unsolved of
151 case Map.lookup name unsolved of
@@ -92,11 +155,168 @@ addConstraint solution unsolved (name, newConstraint) =
92 Just oldConstraint ->
155 Just oldConstraint ->
93 case C.intersect oldConstraint newConstraint of
156 case C.intersect oldConstraint newConstraint of
94 Nothing ->
157 Nothing ->
95− mzero
158+ deadend
96
159
97 Just mergedConstraint ->
160 Just mergedConstraint ->
98− if oldConstraint == mergedConstraint then
161+ if oldConstraint == mergedConstraint
99− return unsolved
162+ then return unsolved
100− else
101− return (Map.insert name mergedConstraint 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+
102
319
320+addProblem :: Problem -> State -> State
321+addProblem problem (State cache registry cDict maybeManager problems) =
322+ State cache registry cDict maybeManager (problem:problems)