Conform.purs

conformLegacyManifest
  :: forall r
   . Manifest
  -> CompilerIndex
  -> DependencyIndex
  -> ValidateDepsError
  -> Run (COMMENT + REGISTRY + STORAGE + LOG + EXCEPT String + AFF + EFFECT + r) (Tuple Manifest (Map PackageName Version))
conformLegacyManifest (Manifest manifest) currentIndex legacyIndex problem = do
  let
    purs :: PackageName
    purs = unsafeFromRight (PackageName.parse "purs")

    legacyRegistry :: Solver.TransitivizedRegistry
    legacyRegistry = Solver.initializeRegistry legacyIndex

    manifestRequired :: SemigroupMap PackageName Intersection
    manifestRequired = Solver.initializeRequired manifest.dependencies

    -- The solveSteps call will produce version ranges for direct transitive
    -- dependencies of those provided via 'required'. This will provide proper
    -- ranges for the majority of missing transitive dependencies. For deeper
    -- layers we will need to fall back to another method.
    legacyTransitive :: Map PackageName Range
    legacyTransitive =
      Map.mapMaybe (\intersect -> Range.mk (Solver.lowerBound intersect) (Solver.upperBound intersect))
        $ Safe.Coercee.coerce
        $ _.required
        $ Solver.solveSteps (Solver.solveSeed { registry: legacyRegistry, required: manifestRequired })

    legacyResolutions :: Map PackageName Version
    legacyResolutions = case Solver.solveFull { registry: legacyRegistry, required: manifestRequired } of
      Left unsolvable -> unsafeCrashWith $ "Legacy resolutions not solvable\n" <> NonEmptyList.foldMap (append "\n  - " <<< Solver.printSolverError) unsolvable
      Right solved -> solved

    associateMissing :: PackageName -> Range
    associateMissing package =
      -- First we look up the package in the produced transitive ranges, as those
      -- are the most likely to be correct.
      case Map.lookup package legacyTransitive of
        Just range -> range
        -- If not found, we search for the ranges described for this dependency
        -- in the manifests of the packages in the resolutions.
        Nothing -> do
          let
            foldFn name prev version =
              -- We look up the target resolution in the index to find its
              -- manifest, in hopes that our missing dependency is listed.
              case Map.lookup name legacyIndex >>= Map.lookup version of
                Nothing -> unsafeCrashWith $ "Missing dependency " <> formatPackageVersion name version <> " in legacy index!"
                Just deps -> case Map.lookup package deps of
                  -- In this case we could not find the missing dependency and
                  -- simply return the accumulator.
                  Nothing -> prev
                  -- If we did find the missing dependency then we intersect
                  -- it with our existing discovered range (if any).
                  Just range -> case prev of
                    Nothing -> Just range
                    Just prevRange -> case Range.intersect range prevRange of
                      Nothing -> unsafeCrashWith $ "Failed to intersect ranges " <> Range.print range <> " and " <> Range.print prevRange
                      Just intersect -> Just intersect

            discovered :: Maybe Range
            discovered = foldlWithIndex foldFn Nothing (Map.delete package legacyResolutions)

          case discovered of
            Nothing -> unsafeCrashWith $ "Failed to discover a range for " <> PackageName.print package
            Just range -> range

    fixUnused names (Manifest m) resolutions = do
      let unused = Map.fromFoldable $ NonEmptySet.map (\name -> Tuple name unit) names
      let fixedDependencies = Map.difference m.dependencies unused
      let fixedResolutions = Map.difference resolutions unused
      Tuple fixedDependencies fixedResolutions

    fixMissing names (Manifest m) = do
      let missing = Map.fromFoldable $ map (\package -> Tuple package (associateMissing package)) (NonEmptySet.toUnfoldable names :: Array _)
      let fixedDependencies = Map.union m.dependencies missing
      -- Once we've fixed the missing dependencies we need to be sure we can still
      -- produce a viable solution with the current index.
      case Solver.solve (un CompilerIndex currentIndex) fixedDependencies of
        Left unsolvable -> unsafeCrashWith $ "Legacy resolutions not solvable\n" <> NonEmptyList.foldMap (append "\n  - " <<< Solver.printSolverError) unsolvable
        Right solved -> Tuple fixedDependencies (Map.delete purs solved)

    previousDepsMessage = Array.fold
      [ "Your package is using a legacy manifest format, so we have adjusted your dependencies to remove unused ones and add direct-imported ones. "
      , "Your dependency list was:\n"
      , "```json\n"
      , printJson (Internal.Codec.packageMap Range.codec) manifest.dependencies
      , "\n```\n"
      ]

    newDepsMessage (Manifest new) = Array.fold
      [ "\nYour new dependency list is:\n"
      , "```json\n"
      , printJson (Internal.Codec.packageMap Range.codec) new.dependencies
      , "\n```\n"
      ]

  case problem of
    UnusedDependencies names -> do
      let (Tuple deps resolutions) = fixUnused names (Manifest manifest) legacyResolutions
      let newManifest = Manifest (manifest { dependencies = deps })
      Comment.comment $ Array.fold
        [ previousDepsMessage
        , "\nWe have removed the following packages: " <> String.joinWith ", " (map PackageName.print (NonEmptySet.toUnfoldable names)) <> "\n"
        , newDepsMessage newManifest
        ]
      pure $ Tuple newManifest resolutions
    MissingDependencies names -> do
      let (Tuple deps resolutions) = fixMissing names (Manifest manifest)
      let newManifest = Manifest (manifest { dependencies = deps })
      Comment.comment $ Array.fold
        [ previousDepsMessage
        , "\nWe have added the following packages: " <> String.joinWith ", " (map PackageName.print (NonEmptySet.toUnfoldable names)) <> "\n"
        , newDepsMessage newManifest
        ]
      pure $ Tuple newManifest resolutions
    UnusedAndMissing { missing, unused } -> do
      let result = fixMissing missing (Manifest manifest)
      let (Tuple newDeps newResolutions) = fixUnused unused (Manifest (manifest { dependencies = (fst result) })) (snd result)
      let newManifest = Manifest (manifest { dependencies = newDeps })
      Comment.comment $ Array.fold
        [ previousDepsMessage
        , "\nWe have removed the following packages: " <> String.joinWith ", " (map PackageName.print (NonEmptySet.toUnfoldable unused)) <> "\n"
        , "We have added the following packages: " <> String.joinWith ", " (map PackageName.print (NonEmptySet.toUnfoldable missing)) <> "\n"
        , newDepsMessage newManifest
        ]
      pure $ Tuple newManifest newResolutions