compiler-versions script: Compute supported compiler versions for all packages (#639)

Author: colinwahl

app/src/App/CLI/Purs.purs

@@ -72,12 +72,15 @@ printCompilerErrors errors = do
   String.joinWith "\n" printed
   where
   printCompilerError :: CompilerError -> String
-  printCompilerError { moduleName, filename, message, errorLink } =
+  printCompilerError { moduleName, filename, message, errorLink, position } =
     String.joinWith "\n"
-      [ foldMap (\name -> "  Module: " <> name <> "\n") moduleName <> "  File: " <> filename
+      [ foldMap (\name -> "  Module: " <> name <> "\n") moduleName <> "  File: " <> filename <> "\n"
       , "  Message:"
       , ""
-      , "  " <> message
+      , message
+      -- The message has a newline, so no need for another.
+      , "  Position:"
+      , "  " <> show position.startLine <> ":" <> show position.startColumn <> " - " <> show position.endLine <> ":" <> show position.endColumn
       , ""
       , "  Error details:"
       , "  " <> errorLink

app/src/App/CLI/PursVersions.purs

@@ -12,6 +12,7 @@ import Run as Run
 import Run.Except (EXCEPT)
 import Run.Except as Except
 
+-- | Returns a sorted array of PureScript compilers supported by the Registry
 pursVersions :: forall r. Run (EXCEPT String + AFF + r) (NonEmptyArray Version)
 pursVersions = do
   result <- Run.liftAff $ _.result =<< Execa.execa "purs-versions" [] identity
@@ -23,4 +24,4 @@ pursVersions = do
 
   case NEA.fromArray success of
     Nothing -> Except.throw "No purs versions"
-    Just arr -> pure arr
+    Just arr -> pure $ NEA.sort arr

app/src/App/Effect/PackageSets.purs

@@ -126,7 +126,7 @@ handle env = case _ of
     index <- Registry.readAllManifests
 
     let
-      sortedPackages = ManifestIndex.toSortedArray index
+      sortedPackages = ManifestIndex.toSortedArray ManifestIndex.IgnoreRanges index
       sortedBatch = sortedPackages # Array.mapMaybe \(Manifest { name, version }) -> do
         update <- Map.lookup name changes
         case update of

app/test/App/CLI/Purs.purs

@@ -46,5 +46,6 @@ spec = do
       FS.Aff.writeTextFile UTF8 file "<contents>"
       result <- Purs.callCompiler { command: Purs.Compile { globs: [ file ] }, cwd: Nothing, version }
       case result of
-        Left (CompilationError [ { position: { startLine: 1, startColumn: 1 } } ]) -> pure unit
+        Left (CompilationError [ { position: { startLine: 1, startColumn: 1 } } ]) ->
+          pure unit
         _ -> Assert.fail "Should have failed with CompilationError"

lib/src/ManifestIndex.purs

@@ -23,6 +23,7 @@ module Registry.ManifestIndex
   , toMap
   , toSortedArray
   , topologicalSort
+  , IncludeRanges(..)
   , writeEntryFile
   ) where
 
@@ -68,6 +69,7 @@ import Registry.Manifest as Manifest
 import Registry.PackageName (PackageName)
 import Registry.PackageName as PackageName
 import Registry.Range (Range)
+import Registry.Range as Range
 import Registry.Version (Version)
 
 -- | An index of package manifests, keyed by package name and version. The index
@@ -86,8 +88,8 @@ toMap :: ManifestIndex -> Map PackageName (Map Version Manifest)
 toMap (ManifestIndex index) = index
 
 -- | Produce an array of manifests topologically sorted by dependencies.
-toSortedArray :: ManifestIndex -> Array Manifest
-toSortedArray (ManifestIndex index) = topologicalSort $ Set.fromFoldable do
+toSortedArray :: IncludeRanges -> ManifestIndex -> Array Manifest
+toSortedArray includeRanges (ManifestIndex index) = topologicalSort includeRanges $ Set.fromFoldable do
   Tuple _ versions <- Map.toUnfoldableUnordered index
   Tuple _ manifest <- Map.toUnfoldableUnordered versions
   [ manifest ]
@@ -163,12 +165,16 @@ maximalIndex manifests = do
       Left errors -> Tuple (Map.insertWith Map.union name (Map.singleton version errors) failed) index
       Right newIndex -> Tuple failed newIndex
 
-  Array.foldl insertManifest (Tuple Map.empty empty) (topologicalSort manifests)
+  Array.foldl insertManifest (Tuple Map.empty empty) (topologicalSort IgnoreRanges manifests)
+
+data IncludeRanges
+  = ConsiderRanges
+  | IgnoreRanges
 
 -- | Topologically sort a set of manifests so that each manifest in the array
 -- | depends only on package versions that have already been encountered.
-topologicalSort :: Set Manifest -> Array Manifest
-topologicalSort manifests =
+topologicalSort :: IncludeRanges -> Set Manifest -> Array Manifest
+topologicalSort includeRanges manifests =
   Array.fromFoldable
     $ List.reverse
     $ List.mapMaybe (flip Graph.lookup graph)
@@ -191,16 +197,13 @@ topologicalSort manifests =
   resolveDependencies :: Manifest -> Tuple (Tuple PackageName Version) (Tuple Manifest (List (Tuple PackageName Version)))
   resolveDependencies manifest@(Manifest { name, version, dependencies }) =
     Tuple (Tuple name version) $ Tuple manifest $ List.fromFoldable do
-      Tuple dependency _ <- Map.toUnfoldable dependencies
+      Tuple dependency range <- Map.toUnfoldable dependencies
       -- This case should not be possible: it means that the manifest indicates
       -- a dependency that does not exist at all. (TODO: Explain)
       let versions = Maybe.fromMaybe [] $ Map.lookup dependency allPackageVersions
-      -- Technically, we should restrict the sort to only apply to package
-      -- versions admitted by the given range. This is faster and correct, but
-      -- fails in the case where we want to produce a maximal index while
-      -- ignoring version bounds.
-      --     included <- Array.filter (Range.includes range) versions
-      included <- versions
+      included <- case includeRanges of
+        ConsiderRanges -> Array.filter (Range.includes range) versions
+        IgnoreRanges -> versions
       [ Tuple dependency included ]
 
 -- | Calculate the directory containing this package in the registry index,

lib/test/Registry/ManifestIndex.purs

@@ -201,7 +201,7 @@ testIndex { satisfied, unsatisfied } = case ManifestIndex.maximalIndex (Set.from
 
 testSorted :: forall m. MonadThrow Error m => Array Manifest -> m Unit
 testSorted input = do
-  let sorted = ManifestIndex.topologicalSort (Set.fromFoldable input)
+  let sorted = ManifestIndex.topologicalSort ManifestIndex.IgnoreRanges (Set.fromFoldable input)
   unless (input == sorted) do
     Assert.fail $ String.joinWith "\n"
       [ Argonaut.stringifyWithIndent 2 $ CA.encode (CA.array manifestCodec') input

scripts/src/CompilerVersions.purs

@@ -6,10 +6,16 @@ import ArgParse.Basic (ArgParser)
 import ArgParse.Basic as Arg
 import Data.Array as Array
 import Data.Array.NonEmpty as NEA
+import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CA.Record
+import Data.Codec.Argonaut.Variant as CA.Variant
 import Data.Formatter.DateTime as Formatter.DateTime
 import Data.Map as Map
+import Data.Maybe as Maybe
+import Data.Profunctor as Profunctor
+import Data.Semigroup.Foldable as Semigroup.Foldable
 import Data.String as String
-import Data.Tuple (uncurry)
+import Data.Variant as Variant
 import Effect.Class.Console as Console
 import Node.FS.Aff as FS.Aff
 import Node.Path as Path
@@ -30,33 +36,42 @@ import Registry.App.Effect.Storage as Storage
 import Registry.Foreign.FSExtra as FS.Extra
 import Registry.Foreign.Octokit as Octokit
 import Registry.Foreign.Tmp as Tmp
+import Registry.Internal.Codec as Internal.Codec
 import Registry.Internal.Format as Internal.Format
 import Registry.Manifest (Manifest(..))
+import Registry.Manifest as Manifest
 import Registry.ManifestIndex as ManifestIndex
 import Registry.PackageName as PackageName
+import Registry.Solver (DependencyIndex)
+import Registry.Solver as Solver
 import Registry.Version as Version
 import Run (AFF, EFFECT, Run)
 import Run as Run
 import Run.Except (EXCEPT)
 import Run.Except as Except
 
-data InputMode
-  = File FilePath
-  | Package PackageName Version
-  | AllPackages
-
-parser :: ArgParser InputMode
-parser = Arg.choose "input (--file or --package or --all)"
-  [ Arg.argument [ "--file" ]
-      """Compute supported compiler versions for packages from a JSON file like: [ "prelude", "console" ]"""
-      # Arg.unformat "FILE_PATH" pure
-      # map File
-  , Arg.argument [ "--package" ]
-      "Compute supported compiler versions for the indicated package"
-      # Arg.unformat "NAME@VERSION" parsePackage
-      # map (uncurry Package)
-  , Arg.flag [ "--all" ] "Compute supported compiler versions for all packages" $> AllPackages
-  ]
+type Arguments =
+  { package :: Maybe (Tuple PackageName Version)
+  , compiler :: Maybe Version
+  }
+
+parser :: ArgParser Arguments
+parser = Arg.fromRecord
+  { package: Arg.choose "input (--all-packages or --package)"
+      [ Arg.flag [ "--all-packages" ] "Check compiler versions for all packages" $> Nothing
+      , Arg.argument [ "--package" ]
+          "Check compiler versions for specific package"
+          # Arg.unformat "NAME@VERSION" parsePackage
+          # map Just
+      ]
+  , compiler: Arg.choose "input (--all-compilers or --compiler)"
+      [ Arg.flag [ "--all-compilers" ] "Check all compiler versions" $> Nothing
+      , Arg.argument [ "--compiler" ]
+          "Check compiler versions for specific package"
+          # Arg.unformat "VERSION" Version.parse
+          # map Just
+      ]
+  }
   where
   parsePackage :: String -> Either String (Tuple PackageName Version)
   parsePackage input = do
@@ -123,13 +138,21 @@ main = launchAff_ do
         >>> Log.interpret (\log -> Log.handleTerminal Normal log *> Log.handleFs Verbose logPath log)
         >>> Run.runBaseAff'
 
-  case arguments of
-    File _ -> Console.log "Unsupported at this time." *> liftEffect (Process.exit 1)
-    Package package version -> interpret $ determineCompilerVersionsForPackage package version
-    AllPackages -> Console.log "Unsupported at this time." *> liftEffect (Process.exit 1)
+  case arguments.package of
+    Just (Tuple package version) -> interpret $ determineCompilerVersionsForPackage package version arguments.compiler
+    Nothing -> do
+      { failures, results } <- interpret $ determineAllCompilerVersions arguments.compiler
+      let resultsDir = Path.concat [ scratchDir, "results" ]
+      FS.Extra.ensureDirectory resultsDir
+      let
+        resultsFile = "compiler-versions-results-" <> String.take 19 (Formatter.DateTime.format Internal.Format.iso8601DateTime now) <> ".json"
+        failuresFile = "compiler-versions-failures-" <> String.take 19 (Formatter.DateTime.format Internal.Format.iso8601DateTime now) <> ".json"
+
+      writeJsonFile (Internal.Codec.packageMap (Internal.Codec.versionMap (CA.array Version.codec))) (Path.concat [ resultsDir, resultsFile ]) results
+      writeJsonFile (Internal.Codec.versionMap (CA.array failureCodec)) (Path.concat [ resultsDir, failuresFile ]) failures
 
-determineCompilerVersionsForPackage :: forall r. PackageName -> Version -> Run (AFF + EFFECT + REGISTRY + EXCEPT String + LOG + STORAGE + r) Unit
-determineCompilerVersionsForPackage package version = do
+determineCompilerVersionsForPackage :: forall r. PackageName -> Version -> Maybe Version -> Run (AFF + EFFECT + REGISTRY + EXCEPT String + LOG + STORAGE + r) Unit
+determineCompilerVersionsForPackage package version mbCompiler = do
   allManifests <- map ManifestIndex.toMap Registry.readAllManifests
   compilerVersions <- PursVersions.pursVersions
   Log.debug $ "Checking Manifest Index for " <> formatPackageVersion package version
@@ -180,10 +203,133 @@ determineCompilerVersionsForPackage package version = do
         else
           goCompilerVersions supported tail
 
-  supported <- goCompilerVersions [] (Array.sort (NEA.toArray compilerVersions))
+  supported <- goCompilerVersions [] (Maybe.maybe (Array.sort (NEA.toArray compilerVersions)) Array.singleton mbCompiler)
 
   if Array.null supported then do
     Log.error $ "Could not find supported compiler versions for " <> formatPackageVersion package version
     Run.liftEffect $ Process.exit 1
   else
     Log.info $ "Found supported compiler versions for " <> formatPackageVersion package version <> ": " <> Array.intercalate ", " (map Version.print supported)
+
+data FailureReason
+  = CannotSolve
+  | CannotCompile
+  | UnknownReason
+
+failureReasonCodec :: JsonCodec FailureReason
+failureReasonCodec = Profunctor.dimap toVariant fromVariant $ CA.Variant.variantMatch
+  { cannotSolve: Left unit
+  , cannotCompile: Left unit
+  , unknownReason: Left unit
+  }
+  where
+  toVariant = case _ of
+    CannotSolve -> Variant.inj (Proxy :: _ "cannotSolve") unit
+    CannotCompile -> Variant.inj (Proxy :: _ "cannotCompile") unit
+    UnknownReason -> Variant.inj (Proxy :: _ "unknownReason") unit
+
+  fromVariant = Variant.match
+    { cannotSolve: \_ -> CannotSolve
+    , cannotCompile: \_ -> CannotCompile
+    , unknownReason: \_ -> UnknownReason
+    }
+
+type Failure =
+  { name :: PackageName
+  , version :: Version
+  , reason :: FailureReason
+  }
+
+failureCodec :: JsonCodec Failure
+failureCodec = CA.Record.object "Failure"
+  { name: PackageName.codec
+  , version: Version.codec
+  , reason: failureReasonCodec
+  }
+
+type CompilerVersionResults =
+  { results :: Map PackageName (Map Version (Array Version))
+  , failures :: Map Version (Array Failure)
+  }
+
+determineAllCompilerVersions :: forall r. Maybe Version -> Run (AFF + EFFECT + REGISTRY + EXCEPT String + LOG + STORAGE + r) CompilerVersionResults
+determineAllCompilerVersions mbCompiler = do
+  allManifests <- Array.mapWithIndex Tuple <<< ManifestIndex.toSortedArray ManifestIndex.ConsiderRanges <$> Registry.readAllManifests
+  compilerVersions <- PursVersions.pursVersions
+  let
+    compilersToCheck = Maybe.maybe compilerVersions NEA.singleton mbCompiler
+    total = Array.length allManifests
+  supportedForVersion <- map Map.fromFoldable $ for compilersToCheck \compiler -> do
+    Log.info $ "Starting checks for " <> Version.print compiler
+    Tuple compiler <$> Array.foldM (checkCompilation compiler total) { failures: [], results: Map.empty } allManifests
+
+  let
+    results = Map.fromFoldableWith (Map.unionWith append) do
+      Tuple compiler supported <- Map.toUnfoldable (map _.results supportedForVersion)
+      Tuple package versions <- Map.toUnfoldable supported
+      Tuple version _ <- Map.toUnfoldable versions
+      [ Tuple package (Map.singleton version [ compiler ]) ]
+
+    failures = map _.failures supportedForVersion
+
+  pure { results, failures }
+  where
+  -- Adds packages which compile with `version` to the `DependencyIndex`
+  checkCompilation :: Version -> Int -> { failures :: Array Failure, results :: DependencyIndex } -> Tuple Int Manifest -> Run _ { failures :: Array Failure, results :: DependencyIndex }
+  checkCompilation compiler total { failures: prevFailures, results: prevResults } (Tuple index manifest@(Manifest { name, version, dependencies })) = do
+    let progress = fold [ "[", Version.print compiler, " ", show (1 + index), "/", show total, "]" ]
+    Log.info $ progress <> " Checking " <> formatPackageVersion name version
+    Log.debug $ "Solving " <> PackageName.print name <> "@" <> Version.print version
+    case Solver.solve prevResults dependencies of
+      Left unsolvable -> do
+        Log.debug $ "Could not solve " <> formatPackageVersion name version <> " with manifest " <> printJson Manifest.codec manifest
+        Log.debug $ Semigroup.Foldable.foldMap1 (append "\n" <<< Solver.printSolverError) unsolvable
+        pure { failures: prevFailures <> [ { name, version, reason: CannotSolve } ], results: prevResults }
+      Right resolutions -> do
+        supported <- installAndBuildWithVersion compiler (Map.insert name version resolutions)
+        case supported of
+          Nothing -> do
+            Log.debug $ "Including package version " <> formatPackageVersion name version
+            pure $ { failures: prevFailures, results: Map.insertWith Map.union name (Map.singleton version dependencies) prevResults }
+          Just reason -> do
+            Log.debug $ "Skipping package version " <> formatPackageVersion name version
+            pure $ { failures: prevFailures <> [ { name, version, reason } ], results: prevResults }
+
+  installAndBuildWithVersion :: Version -> Map PackageName Version -> Run _ (Maybe FailureReason)
+  installAndBuildWithVersion compiler resolutions = do
+    tmp <- Tmp.mkTmpDir
+    let dependenciesDir = Path.concat [ tmp, ".registry" ]
+    FS.Extra.ensureDirectory dependenciesDir
+    Log.debug $ "Created tmp dir for dependencies: " <> dependenciesDir
+    let globs = [ Path.concat [ dependenciesDir, "*/src/**/*.purs" ] ]
+
+    Log.debug "Downloading dependencies..."
+    forWithIndex_ resolutions \name version -> do
+      let
+        filename = PackageName.print name <> "-" <> Version.print version <> ".tar.gz"
+        filepath = Path.concat [ dependenciesDir, filename ]
+      Storage.download name version filepath
+      Tar.extract { cwd: dependenciesDir, archive: filename }
+      Run.liftAff $ FS.Aff.unlink filepath
+
+    Log.debug $ "Compiling with purs@" <> Version.print compiler <> " and globs " <> String.joinWith " " globs
+    compilerOutput <- Run.liftAff $ Purs.callCompiler
+      { command: Purs.Compile { globs }
+      , version: Just compiler
+      , cwd: Just tmp
+      }
+
+    FS.Extra.remove tmp
+
+    case compilerOutput of
+      Left (Purs.UnknownError error) -> do
+        Log.error $ "Failed to compile because of an unknown compiler error: " <> error
+        pure $ Just UnknownReason
+      Left (Purs.MissingCompiler) ->
+        Except.throw "Failed to compile because the compiler was not found."
+      Left (Purs.CompilationError errors) -> do
+        Log.debug $ "Failed to compile with purs@" <> Version.print compiler <> ": " <> Purs.printCompilerErrors errors
+        pure $ Just CannotCompile
+      Right _ -> do
+        Log.debug $ "Successfully compiled with purs@" <> Version.print compiler
+        pure Nothing

scripts/src/LegacyImporter.purs

@@ -227,7 +227,7 @@ runLegacyImport mode logs = do
   Log.info $ formatImportStats $ calculateImportStats legacyRegistry importedIndex
 
   Log.info "Sorting packages for upload..."
-  let allIndexPackages = ManifestIndex.toSortedArray importedIndex.registryIndex
+  let allIndexPackages = ManifestIndex.toSortedArray ManifestIndex.IgnoreRanges importedIndex.registryIndex
 
   Log.info "Removing packages that previously failed publish"
   indexPackages <- allIndexPackages # Array.filterA \(Manifest { name, version }) ->