on master help sign in
Move Deps.Cache to cleaner Deps.Registry module
08ebf20Evan Czaplicki
builder/src/Deps/Cache.hsdeleted−248
@@ -1,248 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Deps.Cache
4− ( optionalUpdate
5− , mandatoryUpdate
6− , PackageRegistry
7− , getPackageRegistry
8− , getVersions
9− , getElmJson
10− , getDocs
11− )
12− where
13−
14−
15−import Prelude hiding (all)
16−import Control.Monad (liftM2)
17−import Control.Monad.Except (catchError, liftIO)
18−import Data.Binary (Binary, get, put)
19−import qualified Data.ByteString as BS
20−import Data.Function (on)
21−import qualified Data.List as List
22−import qualified Data.Map as Map
23−import qualified Data.Name as Name
24−import System.FilePath ((</>))
25−
26−import qualified Deps.Website as Website
27−import qualified Elm.Docs as Docs
28−import qualified Elm.Package as Pkg
29−import qualified Elm.Project.Json as Project
30−import qualified Elm.Version as V
31−import qualified File.IO as IO
32−import qualified Json.Decode as Decode
33−import qualified Reporting.Exit as Exit
34−import qualified Reporting.Exit.Assets as E
35−import qualified Reporting.Progress as Progress
36−import qualified Reporting.Suggest as Suggest
37−import qualified Reporting.Task as Task
38−
39−
40−
41−-- PACKAGE REGISTRY
42−
43−
44−data PackageRegistry =
45− PackageRegistry Int (Map.Map Pkg.Name [V.Version])
46−
47−
48−getPackageRegistry :: Task.Task PackageRegistry
49−getPackageRegistry =
50− do path <- getRegistryPath
51− exists <- liftIO $ IO.exists path
52− if exists
53− then unsafeGetRegistry path
54− else rebuild
55−
56−
57−getRegistryPath :: Task.Task FilePath
58−getRegistryPath =
59− do dir <- Task.getPackageCacheDir
60− return (dir </> "versions.dat")
61−
62−
63−unsafeGetRegistry :: FilePath -> Task.Task PackageRegistry
64−unsafeGetRegistry path =
65− do maybeRegistry <- liftIO $ IO.readBinary path
66− case maybeRegistry of
67− Just registry ->
68− return registry
69−
70− Nothing ->
71− liftIO (putStrLn path) >>
72− Task.throw (error "TODO corrupt binary 3")
73−
74−
75−
76−-- REBUILD
77−
78−
79−rebuild :: Task.Task PackageRegistry
80−rebuild =
81− do path <- getRegistryPath
82− packages <- Website.getAllPackages
83− let size = Map.foldr ((+) . length) 0 packages
84− let registry = PackageRegistry size packages
85− liftIO $ IO.writeBinary path registry
86− return registry
87−
88−
89−
90−-- UPDATE
91−
92−
93−optionalUpdate :: Task.Task PackageRegistry
94−optionalUpdate =
95− update False
96−
97−
98−mandatoryUpdate :: Task.Task PackageRegistry
99−mandatoryUpdate =
100− update True
101−
102−
103−update :: Bool -> Task.Task PackageRegistry
104−update isMandatory =
105− do path <- getRegistryPath
106− exists <- liftIO $ IO.exists path
107− if not exists
108− then rebuild
109− else
110− do registry <- unsafeGetRegistry path
111− if isMandatory
112− then attemptUpdate registry
113− else attemptUpdate registry `catchError` recoverUpdate registry
114−
115−
116−recoverUpdate :: PackageRegistry -> a -> Task.Task PackageRegistry
117−recoverUpdate registry _ =
118− do Task.report Progress.UnableToLoadLatestPackages
119− return registry
120−
121−
122−attemptUpdate :: PackageRegistry -> Task.Task PackageRegistry
123−attemptUpdate oldRegistry@(PackageRegistry size packages) =
124− do news <- Website.getNewPackages size
125− case news of
126− [] ->
127− return oldRegistry
128−
129− _:_ ->
130− let
131− newSize = size + length news
132− newPkgs = List.foldl' addNew packages news
133− newRegistry = PackageRegistry newSize newPkgs
134− in
135− do path <- getRegistryPath
136− liftIO $ IO.writeBinary path newRegistry
137− return newRegistry
138−
139−
140−addNew :: Map.Map Pkg.Name [V.Version] -> (Pkg.Name, V.Version) -> Map.Map Pkg.Name [V.Version]
141−addNew packages (name, version) =
142− Map.insertWith (++) name [version] packages
143−
144−
145−
146−-- GET VERSIONS
147−
148−
149−getVersions :: Pkg.Name -> PackageRegistry -> Either [Pkg.Name] [V.Version]
150−getVersions name (PackageRegistry _ pkgs) =
151− case Map.lookup name pkgs of
152− Just vsns ->
153− Right vsns
154−
155− Nothing ->
156− Left (nearbyNames name (Map.keys pkgs))
157−
158−
159−nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
160−nearbyNames (Pkg.Name author1 project1) possibleNames =
161− let
162− authorDist = authorDistance (Name.toChars author1)
163− projectDist = projectDistance (Name.toChars project1)
164−
165− addDistance name@(Pkg.Name author2 project2) =
166− ( authorDist author2 + projectDist project2, name )
167− in
168− map snd $ take 4 $
169− List.sortBy (compare `on` fst) $
170− map addDistance possibleNames
171−
172−
173−authorDistance :: String -> Name.Name -> Int
174−authorDistance bad possibility =
175− abs (Suggest.distance bad (Name.toChars possibility))
176−
177−
178−projectDistance :: String -> Name.Name -> Int
179−projectDistance bad possibility =
180− if possibility == "elm" || possibility == "elm-explorations" then
181− 0
182− else
183− abs (Suggest.distance bad (Name.toChars possibility))
184−
185−
186−
187−-- PACKAGE INFO
188−
189−
190−getElmJson :: Pkg.Name -> V.Version -> Task.Task Project.PkgInfo
191−getElmJson name version =
192− do dir <- Task.getPackageCacheDirFor name version
193− let elmJson = dir </> "elm.json"
194−
195− exists <- liftIO $ IO.exists elmJson
196−
197− json <-
198− if exists
199− then liftIO (BS.readFile elmJson)
200− else
201− do bits <- Website.getElmJson name version
202− liftIO (BS.writeFile elmJson bits)
203− return bits
204−
205− case Decode.fromByteString Project.pkgDecoder json of
206− Right pkgInfo ->
207− return pkgInfo
208−
209− Left _ ->
210− do liftIO $ IO.remove elmJson
211− Task.throw $ Exit.Assets $ E.CorruptElmJson name version
212−
213−
214−
215−-- DOCS
216−
217−
218−getDocs :: Pkg.Name -> V.Version -> Task.Task Docs.Documentation
219−getDocs name version =
220− do dir <- Task.getPackageCacheDirFor name version
221− let docsJson = dir </> "docs.json"
222−
223− exists <- liftIO $ IO.exists docsJson
224−
225− json <-
226− if exists
227− then liftIO (BS.readFile docsJson)
228− else
229− do bits <- Website.getDocs name version
230− liftIO (BS.writeFile docsJson bits)
231− return bits
232−
233− case Decode.fromByteString (Docs.toDict <$> Decode.list Docs.decoder) json of
234− Right pkgInfo ->
235− return pkgInfo
236−
237− Left _ ->
238− do liftIO $ IO.remove docsJson
239− Task.throw $ Exit.Assets $ E.CorruptDocumentation name version
240−
241−
242−
243−-- BINARY
244−
245−
246−instance Binary PackageRegistry where
247− get = liftM2 PackageRegistry get get
248− put (PackageRegistry a b) = put a >> put b
builder/src/Deps/Registry.hsnew file+246
@@ -0,0 +1,246 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3+module Deps.Registry
4+ ( Registry(..)
5+ , KnownVersions(..)
6+ , read
7+ , fetch
8+ , update
9+ , latest
10+ , getVersions
11+ , getVersions'
12+ )
13+ where
14+
15+
16+import Prelude hiding (read)
17+import Control.Monad (liftM2)
18+import Data.Binary (Binary, get, put)
19+import Data.Function (on)
20+import qualified Data.List as List
21+import qualified Data.Map.Strict as Map
22+import qualified Data.Name as Name
23+import qualified Data.Utf8 as Utf8
24+
25+import qualified Deps.Website as Website
26+import qualified Elm.Package as Pkg
27+import qualified Elm.Version as V
28+import qualified File
29+import qualified Http
30+import qualified Json.Decode as D
31+import qualified Reporting.Exit as E
32+import qualified Reporting.Suggest as Suggest
33+import qualified Stuff
34+
35+
36+
37+-- REGISTRY
38+
39+
40+data Registry =
41+ Registry
42+ { _count :: !Int
43+ , _versions :: !(Map.Map Pkg.Name KnownVersions)
44+ }
45+
46+
47+data KnownVersions =
48+ KnownVersions
49+ { _newest :: V.Version
50+ , _previous :: ![V.Version]
51+ }
52+
53+
54+
55+-- READ
56+
57+
58+read :: Stuff.PackageCache -> IO (Maybe Registry)
59+read cache =
60+ do let path = Stuff.registry cache
61+ exists <- File.exists path
62+ if exists
63+ then File.readBinary path
64+ else return Nothing
65+
66+
67+
68+-- FETCH
69+
70+
71+fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)
72+fetch manager cache =
73+ post manager "/all-packages" allPkgsDecoder $
74+ \versions ->
75+ do let size = Map.foldr' addEntry 0 versions
76+ let registry = Registry size versions
77+ let path = Stuff.registry cache
78+ File.writeBinary path registry
79+ return registry
80+
81+
82+addEntry :: KnownVersions -> Int -> Int
83+addEntry (KnownVersions _ vs) count =
84+ count + 1 + length vs
85+
86+
87+allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
88+allPkgsDecoder =
89+ do pairs <- D.pairs (D.list (D.mapError (\_ -> ()) V.decoder))
90+ checkKeys pairs Map.empty
91+ where
92+ checkKeys pairs pkgs =
93+ case pairs of
94+ [] ->
95+ return pkgs
96+
97+ (key, versions) : rest ->
98+ case Pkg.fromString key of
99+ Right pkg ->
100+ case List.sortBy (flip compare) versions of
101+ [] ->
102+ D.failure ()
103+
104+ v:vs ->
105+ checkKeys rest (Map.insert pkg (KnownVersions v vs) pkgs)
106+
107+ Left _ ->
108+ D.failure ()
109+
110+
111+
112+-- UPDATE
113+
114+
115+update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either E.RegistryProblem Registry)
116+update manager cache oldRegistry@(Registry size packages) =
117+ post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
118+ \news ->
119+ case news of
120+ [] ->
121+ return oldRegistry
122+
123+ _:_ ->
124+ let
125+ newSize = size + length news
126+ newPkgs = foldr addNew packages news
127+ newRegistry = Registry newSize newPkgs
128+ in
129+ do File.writeBinary (Stuff.registry cache) newRegistry
130+ return newRegistry
131+
132+
133+addNew :: (Pkg.Name, V.Version) -> Map.Map Pkg.Name KnownVersions -> Map.Map Pkg.Name KnownVersions
134+addNew (name, version) versions =
135+ let
136+ add maybeKnowns =
137+ case maybeKnowns of
138+ Just (KnownVersions v vs) ->
139+ KnownVersions version (v:vs)
140+
141+ Nothing ->
142+ KnownVersions version []
143+ in
144+ Map.alter (Just . add) name versions
145+
146+
147+newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
148+newPkgDecoder =
149+ do str <- D.string
150+ case Utf8.split 0x40 {-@-} str of
151+ [key, value] ->
152+ case Pkg.fromString key of
153+ Right pkg ->
154+ case V.fromString value of
155+ Just vsn -> return (pkg, vsn)
156+ Nothing -> D.failure ()
157+
158+ Left _ ->
159+ D.failure ()
160+
161+ _ ->
162+ D.failure ()
163+
164+
165+
166+-- LATEST
167+
168+
169+latest :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)
170+latest manager cache =
171+ do maybeOldRegistry <- read cache
172+ case maybeOldRegistry of
173+ Just oldRegistry ->
174+ update manager cache oldRegistry
175+
176+ Nothing ->
177+ fetch manager cache
178+
179+
180+
181+-- GET VERSIONS
182+
183+
184+getVersions :: Pkg.Name -> Registry -> Maybe KnownVersions
185+getVersions name (Registry _ versions) =
186+ Map.lookup name versions
187+
188+
189+getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
190+getVersions' name (Registry _ versions) =
191+ case Map.lookup name versions of
192+ Just kvs -> Right kvs
193+ Nothing -> Left $ nearbyNames name (Map.keys versions)
194+
195+
196+nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
197+nearbyNames (Pkg.Name author1 project1) possibleNames =
198+ let
199+ authorDist = authorDistance (Name.toChars author1)
200+ projectDist = projectDistance (Name.toChars project1)
201+
202+ addDistance name@(Pkg.Name author2 project2) =
203+ ( authorDist author2 + projectDist project2, name )
204+ in
205+ map snd $ take 4 $
206+ List.sortBy (compare `on` fst) $
207+ map addDistance possibleNames
208+
209+
210+authorDistance :: String -> Name.Name -> Int
211+authorDistance bad possibility =
212+ abs (Suggest.distance bad (Name.toChars possibility))
213+
214+
215+projectDistance :: String -> Name.Name -> Int
216+projectDistance bad possibility =
217+ if possibility == "elm" || possibility == "elm-explorations"
218+ then 0
219+ else abs (Suggest.distance bad (Name.toChars possibility))
220+
221+
222+
223+-- POST
224+
225+
226+post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either E.RegistryProblem b)
227+post manager path decoder callback =
228+ Http.post manager (Website.route path []) [] E.RP_Http $
229+ \body ->
230+ case D.fromByteString decoder body of
231+ Right a -> Right <$> callback a
232+ Left _ -> return $ Left E.RP_Data
233+
234+
235+
236+-- BINARY
237+
238+
239+instance Binary Registry where
240+ get = liftM2 Registry get get
241+ put (Registry a b) = put a >> put b
242+
243+
244+instance Binary KnownVersions where
245+ get = liftM2 KnownVersions get get
246+ put (KnownVersions a b) = put a >> put b
builder/src/Generate/Output.hsdeleted−295
@@ -1,295 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Generate.Output
4− ( Mode(..)
5− , Mode.Target(..)
6− , generate
7− , generateReplFile
8− , noDebugUsesInPackage
9− , Output(..)
10− , output
11− )
12− where
13−
14−
15−import Control.Concurrent.MVar (MVar, putMVar)
16−import Control.Monad.Trans (liftIO)
17−import qualified Data.ByteString.Builder as B
18−import qualified Data.Map as Map
19−import Data.Monoid ((<>))
20−import qualified Data.Name as Name
21−import qualified System.Directory as Dir
22−import qualified System.FilePath as FP
23−import System.FilePath ((</>))
24−
25−import qualified Elm.Compiler as Compiler
26−import qualified Elm.Compiler.Objects as Obj
27−import qualified Elm.Interface as I
28−import qualified Elm.ModuleName as ModuleName
29−import qualified Elm.Package as Pkg
30−import qualified Elm.Project.Json as Project
31−import qualified Elm.Project.Summary as Summary
32−import qualified File.Args as Args
33−import qualified File.Crawl as Crawl
34−import qualified File.IO as IO
35−import qualified Generate.Functions as Functions
36−import qualified Generate.Html as Html
37−import qualified Generate.Nitpick as Nitpick
38−import qualified Generate.JavaScript.Mode as Mode
39−import qualified Reporting.Exit as Exit
40−import qualified Reporting.Exit.Make as E
41−import qualified Reporting.Render.Type.Localizer as L
42−import qualified Reporting.Task as Task
43−import qualified Stuff.Paths as Paths
44−import Terminal.Args (Parser(..))
45−
46−
47−
48−-- GENERATE
49−
50−
51−data Mode = Debug | Dev | Prod
52−
53−
54−generate
55− :: Mode
56− -> Mode.Target
57− -> Maybe Output
58− -> Summary.Summary
59− -> Crawl.Result
60− -> Map.Map ModuleName.Raw Compiler.Artifacts
61− -> Task.Task ()
62−generate mode target maybeOutput summary graph@(Crawl.Graph args locals _ _ _) artifacts =
63− case args of
64− Args.Pkg _ ->
65− return ()
66−
67− Args.Roots name names ->
68− do objectGraph <- organize summary graph
69−
70− realMode <-
71− case mode of
72− Debug ->
73− do interfaces <- getInterfaces summary locals artifacts
74− return $ Mode.debug target interfaces
75−
76− Dev ->
77− return $ Mode.dev target
78−
79− Prod ->
80− do noDebugUses summary objectGraph
81− return $ Mode.prod target objectGraph
82−
83− generateMonolith realMode maybeOutput summary objectGraph (name:names)
84−
85−
86−getInterfaces
87− :: Summary.Summary
88− -> Map.Map ModuleName.Raw a
89− -> Map.Map ModuleName.Raw Compiler.Artifacts
90− -> Task.Task I.Interfaces
91−getInterfaces (Summary.Summary root project _ interfaces _) locals artifacts =
92− let
93− pkg =
94− Project.getName project
95−
96− addArtifact home (Compiler.Artifacts elmi _ _) ifaces =
97− (ModuleName.Canonical pkg home, elmi) : ifaces
98−
99− addInterface home iface ifaces =
100− (ModuleName.Canonical pkg home, iface) : ifaces
101−
102− readInterface home _ =
103− IO.readBinary (Paths.elmi root home)
104− in
105− do cached <- Map.traverseWithKey readInterface (Map.difference locals artifacts)
106− return $
107− Map.union interfaces $ Map.fromList $
108− Map.foldrWithKey addInterface (Map.foldrWithKey addArtifact [] artifacts) cached
109−
110−
111−
112−-- GENERATE MONOLITH
113−
114−
115−generateMonolith
116− :: Mode.Mode
117− -> Maybe Output
118− -> Summary.Summary
119− -> Obj.Graph
120− -> [ModuleName.Raw]
121− -> Task.Task ()
122−generateMonolith mode maybeOutput (Summary.Summary _ project _ _ _) graph rootNames =
123− do let pkg = Project.getName project
124− let roots = map (ModuleName.Canonical pkg) rootNames
125− case Obj.generate mode graph roots of
126− Obj.None ->
127− return ()
128−
129− Obj.Some name _names builder ->
130− let
131− monolith =
132− "(function(scope){\n'use strict';"
133− <> Functions.functions <> builder <> "}(this));"
134− in
135− liftIO $
136− case maybeOutput of
137− Nothing ->
138− IO.writeBuilder "index.html" (Html.sandwich name monolith)
139−
140− Just output_ ->
141− case output_ of
142− None ->
143− return ()
144−
145− JavaScript maybeDir fileName ->
146− do path <- toWritablePath maybeDir fileName
147− IO.writeBuilder path monolith
148−
149− HtmlBuilder mvar ->
150− putMVar mvar (Html.sandwich name monolith)
151−
152− Html maybeDir fileName ->
153− do path <- toWritablePath maybeDir fileName
154− IO.writeBuilder path (Html.sandwich name monolith)
155−
156−
157−
158−-- GENERATE REPL MONOLITH
159−
160−
161−generateReplFile
162− :: Bool
163− -> L.Localizer
164− -> Summary.Summary
165− -> Crawl.Result
166− -> I.Interface
167− -> Name.Name
168− -> Task.Task FilePath
169−generateReplFile noColors localizer summary@(Summary.Summary _ project _ _ _) graph iface name =
170− do
171− objectGraph <- organize summary graph
172−
173− let home = ModuleName.Canonical (Project.getName project) Name.replModule
174− let builder = Obj.generateForRepl (not noColors) localizer objectGraph iface home name
175−
176− liftIO $ IO.writeBuilder (Paths.temp "js") $
177− replRecovery <> "(function(){\n'use strict';" <> Functions.functions <> builder <> "}());"
178−
179− return (Paths.temp "js")
180−
181−
182−replRecovery :: B.Builder
183−replRecovery =
184− "process.on('uncaughtException', function(err) { process.stderr.write(err.toString()); process.exit(1); });"
185−
186−
187−
188−-- ORGANIZE
189−
190−
191−organize :: Summary.Summary -> Crawl.Result -> Task.Task Obj.Graph
192−organize (Summary.Summary root _ _ _ deps) (Crawl.Graph _ locals _ _ _) =
193− do localObjs <- Obj.unions <$> traverse (loadModuleObj root) (Map.keys locals)
194− foreignObjs <- Obj.unions <$> traverse loadPackageObj (Map.toList deps)
195− return (Obj.union localObjs foreignObjs)
196−
197−
198−loadModuleObj :: FilePath -> ModuleName.Raw -> Task.Task Obj.Graph
199−loadModuleObj root name =
200− IO.readBinary (Paths.elmo root name)
201−
202−
203−loadPackageObj :: ( Pkg.Name, (Pkg.Version, deps) ) -> Task.Task Obj.Graph
204−loadPackageObj ( name, (version,_) ) =
205− do dir <- Task.getPackageCacheDirFor name version
206− IO.readBinary (dir </> "objs.dat")
207−
208−
209−
210−-- NO DEBUG USES
211−
212−
213−noDebugUses :: Summary.Summary -> Obj.Graph -> Task.Task ()
214−noDebugUses (Summary.Summary _ project _ _ _) graph =
215− case Nitpick.findDebugUses (Project.getName project) graph of
216− [] ->
217− return ()
218−
219− m:ms ->
220− Task.throw (Exit.Make (E.CannotOptimizeDebugValues m ms))
221−
222−
223−noDebugUsesInPackage :: Summary.Summary -> Crawl.Result -> Task.Task ()
224−noDebugUsesInPackage summary graph =
225− noDebugUses summary =<< organize summary graph
226−
227−
228−
229−-- OUTPUT
230−
231−
232−data Output
233− = None
234− | Html (Maybe FilePath) FilePath
235− | JavaScript (Maybe FilePath) FilePath
236− | HtmlBuilder (MVar B.Builder)
237−
238−
239−toWritablePath :: Maybe FilePath -> FilePath -> IO FilePath
240−toWritablePath maybeDir fileName =
241− case maybeDir of
242− Nothing ->
243− do return fileName
244−
245− Just dir ->
246− do Dir.createDirectoryIfMissing True dir
247− return (dir </> fileName)
248−
249−
250−
251−-- OUTPUT PARSER
252−
253−
254−output :: Parser Output
255−output =
256− Parser
257− { _singular = "output file"
258− , _plural = "output files"
259− , _parser = parseOutput
260− , _suggest = \_ -> return []
261− , _examples = exampleOutput
262− }
263−
264−
265−parseOutput :: String -> Maybe Output
266−parseOutput string =
267− if string == "/dev/null" || string == "NUL" || string == "$null" then
268− Just None
269−
270− else if FP.takeExtension string == ".html" && length string > 5 then
271− splitOutput Html string
272−
273− else if FP.takeExtension string == ".js" && length string > 3 then
274− splitOutput JavaScript string
275−
276− else
277− Nothing
278−
279−
280−splitOutput :: (Maybe FilePath -> FilePath -> Output) -> String -> Maybe Output
281−splitOutput toOutput string =
282− case FP.splitPath string of
283− [] ->
284− Nothing
285−
286− [name] ->
287− Just $ toOutput Nothing name
288−
289− segments ->
290− Just $ toOutput (Just (FP.joinPath (init segments))) (last segments)
291−
292−
293−exampleOutput :: String -> IO [String]
294−exampleOutput _ =
295− return [ "elm.js", "index.html", "/dev/null" ]