Skip to content

Commit 64e3a6c

Browse files
thomashoneymanthomashoneyman
authored
Add caching to compile-versions (#640)
1 parent 92d014a commit 64e3a6c

File tree

1 file changed

+162
-83
lines changed

1 file changed

+162
-83
lines changed

‎scripts/src/CompilerVersions.purs‎

Lines changed: 162 additions & 83 deletions
Original file line numberDiff line numberDiff line change
@@ -7,13 +7,15 @@ import ArgParse.Basic as Arg
77
import Data.Array as Array
88
import Data.Array.NonEmpty as NEA
99
import Data.Codec.Argonaut as CA
10+
import Data.Codec.Argonaut.Common as Codec.Common
1011
import Data.Codec.Argonaut.Record as CA.Record
1112
import Data.Codec.Argonaut.Variant as CA.Variant
13+
import Data.Exists as Exists
1214
import Data.Formatter.DateTime as Formatter.DateTime
1315
import Data.Map as Map
14-
import Data.Maybe as Maybe
1516
import Data.Profunctor as Profunctor
1617
import Data.Semigroup.Foldable as Semigroup.Foldable
18+
import Data.Set as Set
1719
import Data.String as String
1820
import Data.Variant as Variant
1921
import Effect.Class.Console as Console
@@ -24,6 +26,7 @@ import Registry.App.CLI.Git as Git
2426
import Registry.App.CLI.Purs as Purs
2527
import Registry.App.CLI.PursVersions as PursVersions
2628
import Registry.App.CLI.Tar as Tar
29+
import Registry.App.Effect.Cache (class FsEncodable, class MemoryEncodable, Cache, FsEncoding(..), MemoryEncoding(..))
2730
import Registry.App.Effect.Cache as Cache
2831
import Registry.App.Effect.Env as Env
2932
import Registry.App.Effect.GitHub as GitHub
@@ -50,9 +53,15 @@ import Run as Run
5053
import Run.Except (EXCEPT)
5154
import Run.Except as Except
5255

56+
data TargetCompiler
57+
= AllCompilers
58+
| OneCompiler Version
59+
60+
derive instance Eq TargetCompiler
61+
5362
type Arguments =
5463
{ package :: Maybe (Tuple PackageName Version)
55-
, compiler :: Maybe Version
64+
, compiler :: TargetCompiler
5665
}
5766

5867
parser :: ArgParser Arguments
@@ -65,11 +74,11 @@ parser = Arg.fromRecord
6574
# map Just
6675
]
6776
, compiler: Arg.choose "input (--all-compilers or --compiler)"
68-
[ Arg.flag [ "--all-compilers" ] "Check all compiler versions" $> Nothing
77+
[ Arg.flag [ "--all-compilers" ] "Check all compiler versions" $> AllCompilers
6978
, Arg.argument [ "--compiler" ]
7079
"Check compiler versions for specific package"
7180
# Arg.unformat "VERSION" Version.parse
72-
# map Just
81+
# map OneCompiler
7382
]
7483
}
7584
where
@@ -135,57 +144,66 @@ main = launchAff_ do
135144
>>> Registry.interpret (Registry.handle registryEnv)
136145
>>> Storage.interpret (Storage.handleReadOnly cache)
137146
>>> GitHub.interpret (GitHub.handle { octokit, cache, ref: githubCacheRef })
147+
>>> Cache.interpret _compilationCache (Cache.handleFs cache :: Cache CompilationCache ~> _)
138148
>>> Log.interpret (\log -> Log.handleTerminal Normal log *> Log.handleFs Verbose logPath log)
139149
>>> Run.runBaseAff'
140150

141151
case arguments.package of
142-
Just (Tuple package version) -> interpret $ determineCompilerVersionsForPackage package version arguments.compiler
152+
Just (Tuple package version) ->
153+
interpret $ compilersForPackageVersion package version arguments.compiler
143154
Nothing -> do
144-
{ failures, results } <- interpret $ determineAllCompilerVersions arguments.compiler
155+
{ failures, results } <- interpret $ compilersForAllPackages arguments.compiler
145156
let resultsDir = Path.concat [ scratchDir, "results" ]
146157
FS.Extra.ensureDirectory resultsDir
147158
let
148159
resultsFile = "compiler-versions-results-" <> String.take 19 (Formatter.DateTime.format Internal.Format.iso8601DateTime now) <> ".json"
149160
failuresFile = "compiler-versions-failures-" <> String.take 19 (Formatter.DateTime.format Internal.Format.iso8601DateTime now) <> ".json"
150-
151161
writeJsonFile (Internal.Codec.packageMap (Internal.Codec.versionMap (CA.array Version.codec))) (Path.concat [ resultsDir, resultsFile ]) results
152162
writeJsonFile (Internal.Codec.versionMap (CA.array failureCodec)) (Path.concat [ resultsDir, failuresFile ]) failures
153163

154-
determineCompilerVersionsForPackage :: forall r. PackageName -> Version -> Maybe Version -> Run (AFF + EFFECT + REGISTRY + EXCEPT String + LOG + STORAGE + r) Unit
155-
determineCompilerVersionsForPackage package version mbCompiler = do
156-
allManifests <- map ManifestIndex.toMap Registry.readAllManifests
157-
compilerVersions <- PursVersions.pursVersions
158-
Log.debug $ "Checking Manifest Index for " <> formatPackageVersion package version
159-
Manifest { dependencies } <- Except.rethrow $ (note "Invalid Version" <<< Map.lookup version <=< note "Invalid PackageName" <<< Map.lookup package) allManifests
164+
compilersForPackageVersion
165+
:: forall r
166+
. PackageName
167+
-> Version
168+
-> TargetCompiler
169+
-> Run (REGISTRY + STORAGE + LOG + EXCEPT String + AFF + EFFECT + r) Unit
170+
compilersForPackageVersion package version target = do
171+
allManifests <- Registry.readAllManifests
172+
supportedCompilers <- PursVersions.pursVersions
173+
Log.debug $ "Checking manifest index for " <> formatPackageVersion package version
174+
Manifest { dependencies } <- Except.rethrow (note "No entry found in manifest index." (ManifestIndex.lookup package version allManifests))
175+
-- FIXME: Support packages with dependencies once we have compilers versions
176+
-- in metadata.
160177
unless (Map.isEmpty dependencies) do
161178
Log.error "Cannot check package that has dependencies."
162179
Except.throw "Cannot check package that has dependencies."
163-
tmp <- Run.liftAff Tmp.mkTmpDir
180+
181+
tmp <- Run.liftEffect Tmp.mkTmpDir
164182
let formattedName = formatPackageVersion package version
165183
let extractedName = PackageName.print package <> "-" <> Version.print version
166184
let tarballName = extractedName <> ".tar.gz"
167185
let tarballPath = Path.concat [ tmp, tarballName ]
168186
let extractedPath = Path.concat [ tmp, extractedName ]
169187
let installPath = Path.concat [ tmp, formattedName ]
188+
170189
Log.debug $ "Installing " <> formattedName
171190
Storage.download package version tarballPath
191+
Run.liftEffect $ Tar.extract { cwd: tmp, archive: tarballName }
172192
Run.liftAff do
173-
Tar.extract { cwd: tmp, archive: tarballName }
174193
FS.Extra.remove tarballPath
175194
FS.Aff.rename extractedPath installPath
195+
176196
Log.debug $ "Installed " <> formatPackageVersion package version
177197
Log.debug $ "Finding supported compiler versions for " <> formatPackageVersion package version
178198

179199
let
180200
checkCompiler compiler = do
181201
Log.debug $ "Trying to compile " <> formatPackageVersion package version <> " with purs@" <> Version.print compiler
182-
183202
result <- Run.liftAff $ Purs.callCompiler
184203
{ command: Purs.Compile { globs: [ Path.concat [ formattedName, "src/**/*.purs" ] ] }
185204
, version: Just compiler
186205
, cwd: Just tmp
187206
}
188-
189207
case result of
190208
Left _ -> do
191209
Log.debug $ "Failed to compile " <> formatPackageVersion package version <> " with purs@" <> Version.print compiler
@@ -203,65 +221,27 @@ determineCompilerVersionsForPackage package version mbCompiler = do
203221
else
204222
goCompilerVersions supported tail
205223

206-
supported <- goCompilerVersions [] (Maybe.maybe (Array.sort (NEA.toArray compilerVersions)) Array.singleton mbCompiler)
224+
supported <- goCompilerVersions [] $ case target of
225+
AllCompilers -> NEA.toArray supportedCompilers
226+
OneCompiler compiler -> [ compiler ]
207227

208228
if Array.null supported then do
209229
Log.error $ "Could not find supported compiler versions for " <> formatPackageVersion package version
210230
Run.liftEffect $ Process.exit 1
211231
else
212232
Log.info $ "Found supported compiler versions for " <> formatPackageVersion package version <> ": " <> Array.intercalate ", " (map Version.print supported)
213233

214-
data FailureReason
215-
= CannotSolve
216-
| CannotCompile
217-
| UnknownReason
218-
219-
failureReasonCodec :: JsonCodec FailureReason
220-
failureReasonCodec = Profunctor.dimap toVariant fromVariant $ CA.Variant.variantMatch
221-
{ cannotSolve: Left unit
222-
, cannotCompile: Left unit
223-
, unknownReason: Left unit
224-
}
225-
where
226-
toVariant = case _ of
227-
CannotSolve -> Variant.inj (Proxy :: _ "cannotSolve") unit
228-
CannotCompile -> Variant.inj (Proxy :: _ "cannotCompile") unit
229-
UnknownReason -> Variant.inj (Proxy :: _ "unknownReason") unit
230-
231-
fromVariant = Variant.match
232-
{ cannotSolve: \_ -> CannotSolve
233-
, cannotCompile: \_ -> CannotCompile
234-
, unknownReason: \_ -> UnknownReason
235-
}
236-
237-
type Failure =
238-
{ name :: PackageName
239-
, version :: Version
240-
, reason :: FailureReason
241-
}
242-
243-
failureCodec :: JsonCodec Failure
244-
failureCodec = CA.Record.object "Failure"
245-
{ name: PackageName.codec
246-
, version: Version.codec
247-
, reason: failureReasonCodec
248-
}
249-
250-
type CompilerVersionResults =
251-
{ results :: Map PackageName (Map Version (Array Version))
252-
, failures :: Map Version (Array Failure)
253-
}
254-
255-
determineAllCompilerVersions :: forall r. Maybe Version -> Run (AFF + EFFECT + REGISTRY + EXCEPT String + LOG + STORAGE + r) CompilerVersionResults
256-
determineAllCompilerVersions mbCompiler = do
257-
allManifests <- Array.mapWithIndex Tuple <<< ManifestIndex.toSortedArray ManifestIndex.ConsiderRanges <$> Registry.readAllManifests
258-
compilerVersions <- PursVersions.pursVersions
259-
let
260-
compilersToCheck = Maybe.maybe compilerVersions NEA.singleton mbCompiler
261-
total = Array.length allManifests
234+
compilersForAllPackages :: forall r. TargetCompiler -> Run (COMPILATION_CACHE + REGISTRY + STORAGE + LOG + EXCEPT String + AFF + EFFECT + r) CompilerVersionResults
235+
compilersForAllPackages target = do
236+
index <- Registry.readAllManifests
237+
let sortedManifests = Array.mapWithIndex Tuple (ManifestIndex.toSortedArray ManifestIndex.ConsiderRanges index)
238+
let manifestCount = Array.length sortedManifests
239+
compilersToCheck <- case target of
240+
AllCompilers -> PursVersions.pursVersions
241+
OneCompiler version -> pure (NEA.singleton version)
262242
supportedForVersion <- map Map.fromFoldable $ for compilersToCheck \compiler -> do
263-
Log.info $ "Starting checks for " <> Version.print compiler
264-
Tuple compiler <$> Array.foldM (checkCompilation compiler total) { failures: [], results: Map.empty } allManifests
243+
Log.info $ "Starting checks for compiler " <> Version.print compiler
244+
Tuple compiler <$> Array.foldM (checkCompilation compiler manifestCount) { failures: [], results: Map.empty } sortedManifests
265245

266246
let
267247
results = Map.fromFoldableWith (Map.unionWith append) do
@@ -279,21 +259,44 @@ determineAllCompilerVersions mbCompiler = do
279259
checkCompilation compiler total { failures: prevFailures, results: prevResults } (Tuple index manifest@(Manifest { name, version, dependencies })) = do
280260
let progress = fold [ "[", Version.print compiler, " ", show (1 + index), "/", show total, "]" ]
281261
Log.info $ progress <> " Checking " <> formatPackageVersion name version
282-
Log.debug $ "Solving " <> PackageName.print name <> "@" <> Version.print version
283-
case Solver.solve prevResults dependencies of
284-
Left unsolvable -> do
285-
Log.debug $ "Could not solve " <> formatPackageVersion name version <> " with manifest " <> printJson Manifest.codec manifest
286-
Log.debug $ Semigroup.Foldable.foldMap1 (append "\n" <<< Solver.printSolverError) unsolvable
287-
pure { failures: prevFailures <> [ { name, version, reason: CannotSolve } ], results: prevResults }
288-
Right resolutions -> do
289-
supported <- installAndBuildWithVersion compiler (Map.insert name version resolutions)
290-
case supported of
291-
Nothing -> do
292-
Log.debug $ "Including package version " <> formatPackageVersion name version
293-
pure $ { failures: prevFailures, results: Map.insertWith Map.union name (Map.singleton version dependencies) prevResults }
294-
Just reason -> do
295-
Log.debug $ "Skipping package version " <> formatPackageVersion name version
296-
pure $ { failures: prevFailures <> [ { name, version, reason } ], results: prevResults }
262+
263+
let
264+
successResult = { failures: prevFailures, results: Map.insertWith Map.union name (Map.singleton version dependencies) prevResults }
265+
failResult reason = { failures: prevFailures <> [ { name, version, reason } ], results: prevResults }
266+
runCheckWithCache prevCache = do
267+
Log.debug $ "Solving " <> PackageName.print name <> "@" <> Version.print version
268+
case Solver.solve prevResults dependencies of
269+
Left unsolvable -> do
270+
Log.debug $ "Could not solve " <> formatPackageVersion name version <> " with manifest " <> printJson Manifest.codec manifest
271+
Log.debug $ Semigroup.Foldable.foldMap1 (append "\n" <<< Solver.printSolverError) unsolvable
272+
Cache.put _compilationCache (CompileResult name version) $ case prevCache of
273+
Nothing -> { failed: Map.singleton compiler CannotSolve, succeeded: Set.empty }
274+
Just prev -> prev { failed = Map.insert compiler CannotSolve prev.failed }
275+
pure $ failResult CannotSolve
276+
Right resolutions -> do
277+
supported <- installAndBuildWithVersion compiler (Map.insert name version resolutions)
278+
case supported of
279+
Nothing -> do
280+
Log.debug $ "Including package version " <> formatPackageVersion name version
281+
Cache.put _compilationCache (CompileResult name version) $ case prevCache of
282+
Nothing -> { failed: Map.empty, succeeded: Set.singleton compiler }
283+
Just prev -> prev { succeeded = Set.insert compiler prev.succeeded }
284+
pure successResult
285+
Just reason -> do
286+
Log.debug $ "Skipping package version " <> formatPackageVersion name version
287+
Cache.put _compilationCache (CompileResult name version) $ case prevCache of
288+
Nothing -> { failed: Map.singleton compiler reason, succeeded: Set.empty }
289+
Just prev -> prev { failed = Map.insert compiler reason prev.failed }
290+
pure $ failResult reason
291+
292+
Cache.get _compilationCache (CompileResult name version) >>= case _ of
293+
Just { failed } | Just reason <- Map.lookup compiler failed -> do
294+
Log.debug "Got failure from cache."
295+
pure $ failResult reason
296+
Just { succeeded } | Set.member compiler succeeded -> do
297+
Log.debug "Got success from cache."
298+
pure successResult
299+
cache -> runCheckWithCache cache
297300

298301
installAndBuildWithVersion :: Version -> Map PackageName Version -> Run _ (Maybe FailureReason)
299302
installAndBuildWithVersion compiler resolutions = do
@@ -333,3 +336,79 @@ determineAllCompilerVersions mbCompiler = do
333336
Right _ -> do
334337
Log.debug $ "Successfully compiled with purs@" <> Version.print compiler
335338
pure Nothing
339+
340+
type Failure =
341+
{ name :: PackageName
342+
, version :: Version
343+
, reason :: FailureReason
344+
}
345+
346+
failureCodec :: JsonCodec Failure
347+
failureCodec = CA.Record.object "Failure"
348+
{ name: PackageName.codec
349+
, version: Version.codec
350+
, reason: failureReasonCodec
351+
}
352+
353+
type CompilerVersionResults =
354+
{ results :: Map PackageName (Map Version (Array Version))
355+
, failures :: Map Version (Array Failure)
356+
}
357+
358+
data FailureReason
359+
= CannotSolve
360+
| CannotCompile
361+
| UnknownReason
362+
363+
derive instance Eq FailureReason
364+
365+
failureReasonCodec :: JsonCodec FailureReason
366+
failureReasonCodec = Profunctor.dimap toVariant fromVariant $ CA.Variant.variantMatch
367+
{ cannotSolve: Left unit
368+
, cannotCompile: Left unit
369+
, unknownReason: Left unit
370+
}
371+
where
372+
toVariant = case _ of
373+
CannotSolve -> Variant.inj (Proxy :: _ "cannotSolve") unit
374+
CannotCompile -> Variant.inj (Proxy :: _ "cannotCompile") unit
375+
UnknownReason -> Variant.inj (Proxy :: _ "unknownReason") unit
376+
377+
fromVariant = Variant.match
378+
{ cannotSolve: \_ -> CannotSolve
379+
, cannotCompile: \_ -> CannotCompile
380+
, unknownReason: \_ -> UnknownReason
381+
}
382+
383+
type CompilationResults =
384+
{ failed :: Map Version FailureReason
385+
, succeeded :: Set Version
386+
}
387+
388+
compilationResultsCodec :: JsonCodec CompilationResults
389+
compilationResultsCodec = CA.Record.object "CompilationResults"
390+
{ failed: Internal.Codec.versionMap failureReasonCodec
391+
, succeeded: Codec.Common.set Version.codec
392+
}
393+
394+
-- | A key type for caching compilation results
395+
data CompilationCache (c :: Type -> Type -> Type) a = CompileResult PackageName Version (c CompilationResults a)
396+
397+
instance Functor2 c => Functor (CompilationCache c) where
398+
map k = case _ of
399+
CompileResult name version a -> CompileResult name version (map2 k a)
400+
401+
instance MemoryEncodable CompilationCache where
402+
encodeMemory = case _ of
403+
CompileResult name version next ->
404+
Exists.mkExists $ Key ("CompileResult__" <> PackageName.print name <> "-" <> Version.print version) next
405+
406+
instance FsEncodable CompilationCache where
407+
encodeFs = case _ of
408+
CompileResult name version next ->
409+
Exists.mkExists $ AsJson ("CompileResult__" <> PackageName.print name <> "-" <> Version.print version) compilationResultsCodec next
410+
411+
type COMPILATION_CACHE r = (compilationCache :: Cache CompilationCache | r)
412+
413+
_compilationCache :: Proxy "compilationCache"
414+
_compilationCache = Proxy

0 commit comments

Comments
 (0)