Prune unused dependencies from manifests generated from spago.dhall files

app/fixtures/github-packages/effect-4.0.0/bower.json

@@ -16,6 +16,7 @@
     "package.json"
   ],
   "dependencies": {
-    "purescript-prelude": "^6.0.0"
+    "purescript-prelude": "^6.0.0",
+    "purescript-type-equality": "^4.0.0"
   }
 }

app/fixtures/registry-index/ty/pe/type-equality

@@ -0,0 +1 @@
+{"name":"type-equality","version":"4.0.1","license":"BSD-3-Clause","location":{"githubOwner":"purescript","githubRepo":"purescript-type-equality"},"dependencies":{}}

app/fixtures/registry/metadata/type-equality.json

@@ -0,0 +1,15 @@
+{
+  "location": {
+    "githubOwner": "purescript",
+    "githubRepo": "purescript-type-equality"
+  },
+  "published": {
+    "4.0.1": {
+      "bytes": 2184,
+      "hash": "sha256-Hs9D6Y71zFi/b+qu5NSbuadUQXe5iv5iWx0226vOHUw=",
+      "publishedTime": "2022-04-27T18:00:18.000Z",
+      "ref": "v4.0.1"
+    }
+  },
+  "unpublished": {}
+}

app/src/App/CLI/Purs.purs

@@ -96,12 +96,14 @@ data PursCommand
   = Version
   | Compile { globs :: Array FilePath }
   | Publish { resolutions :: FilePath }
+  | Graph { globs :: Array FilePath }
 
 printCommand :: PursCommand -> Array String
 printCommand = case _ of
   Version -> [ "--version" ]
   Compile { globs } -> [ "compile" ] <> globs <> [ "--json-errors" ]
   Publish { resolutions } -> [ "publish", "--manifest", "purs.json", "--resolutions", resolutions ]
+  Graph { globs } -> [ "graph" ] <> globs <> [ "--json-errors" ]
 
 -- | Call a specific version of the PureScript compiler
 callCompiler :: CompilerArgs -> Aff (Either CompilerFailure String)
@@ -118,7 +120,8 @@ callCompiler compilerArgs = do
             $ Version.print version
 
     errorsCodec = CA.Record.object "CompilerErrors"
-      { errors: CA.array compilerErrorCodec }
+      { errors: CA.array compilerErrorCodec
+      }
 
   result <- _.result =<< Execa.execa purs (printCommand compilerArgs.command) (_ { cwd = compilerArgs.cwd })
   pure case result of

app/test/App/API.purs

@@ -6,13 +6,15 @@ import Data.Array.NonEmpty as NonEmptyArray
 import Data.Foldable (traverse_)
 import Data.Map as Map
 import Data.Set as Set
+import Data.String as String
 import Data.String.NonEmpty as NonEmptyString
 import Effect.Aff as Aff
 import Effect.Ref as Ref
 import Node.FS.Aff as FS.Aff
 import Node.Path as Path
 import Node.Process as Process
 import Registry.App.API as API
+import Registry.App.CLI.Tar as Tar
 import Registry.App.Effect.Env as Env
 import Registry.App.Effect.Log as Log
 import Registry.App.Effect.Pursuit as Pursuit
@@ -23,7 +25,10 @@ import Registry.Constants as Constants
 import Registry.Foreign.FSExtra as FS.Extra
 import Registry.Foreign.FastGlob as FastGlob
 import Registry.Foreign.Tmp as Tmp
+import Registry.Internal.Codec as Internal.Codec
+import Registry.Manifest as Manifest
 import Registry.PackageName as PackageName
+import Registry.Range as Range
 import Registry.Test.Assert as Assert
 import Registry.Test.Assert.Run as Assert.Run
 import Registry.Test.Utils as Utils
@@ -52,11 +57,24 @@ spec = do
     removeIgnoredTarballFiles
     copySourceFiles
 
+  Spec.describe "Parses installed paths" do
+    Spec.it "Parses install path <tmp>/my-package-1.0.0/..." do
+      tmp <- Tmp.mkTmpDir
+      let moduleA = Path.concat [ tmp, "my-package-1.0.0", "src", "ModuleA.purs" ]
+      case API.parseInstalledModulePath { prefix: tmp, path: moduleA } of
+        Left err -> Assert.fail $ "Expected to parse " <> moduleA <> " but got error: " <> err
+        Right { name, version } -> do
+          Assert.shouldEqual name (Utils.unsafePackageName "my-package")
+          Assert.shouldEqual version (Utils.unsafeVersion "1.0.0")
+      FS.Extra.remove tmp
+
   Spec.describe "API pipelines run correctly" $ Spec.around withCleanEnv do
-    Spec.it "Publish" \{ workdir, index, metadata, storageDir, githubDir } -> do
+    Spec.it "Publish a legacy-converted package with unused deps" \{ workdir, index, metadata, storageDir, githubDir } -> do
       let testEnv = { workdir, index, metadata, username: "jon", storage: storageDir, github: githubDir }
       Assert.Run.runTestEffects testEnv do
-        -- We'll publish [email protected]
+        -- We'll publish [email protected] from the fixtures/github-packages
+        -- directory, which has an unnecessary dependency on 'type-equality'
+        -- inserted into it.
         let
           name = Utils.unsafePackageName "effect"
           version = Utils.unsafeVersion "4.0.0"
@@ -83,11 +101,28 @@ spec = do
           unless (Set.member version versions) do
             Except.throw $ "Expected " <> formatPackageVersion name version <> " to be published to registry storage."
 
+        -- Let's verify the manifest does not include the unnecessary
+        -- 'type-equality' dependency...
+        Storage.download name version "effect-result"
+        Tar.extract { cwd: workdir, archive: "effect-result" }
+        Run.liftAff (readJsonFile Manifest.codec (Path.concat [ "effect-4.0.0", "purs.json" ])) >>= case _ of
+          Left err -> Except.throw $ "Expected [email protected] to be downloaded to effect-4.0.0 with a purs.json but received error " <> err
+          Right (Manifest manifest) -> do
+            let expectedDeps = Map.singleton (Utils.unsafePackageName "prelude") (Utils.unsafeRange ">=6.0.0 <7.0.0")
+            when (manifest.dependencies /= expectedDeps) do
+              Except.throw $ String.joinWith "\n"
+                [ "Expected [email protected] to have dependencies"
+                , printJson (Internal.Codec.packageMap Range.codec) expectedDeps
+                , "\nbut got"
+                , printJson (Internal.Codec.packageMap Range.codec) manifest.dependencies
+                ]
+
         -- Finally, we can verify that publishing the package again should fail
         -- since it already exists.
         Except.runExcept (API.publish CurrentPackage publishArgs) >>= case _ of
           Left _ -> pure unit
           Right _ -> Except.throw $ "Expected publishing " <> formatPackageVersion name version <> " twice to fail."
+
   where
   withCleanEnv :: (PipelineEnv -> Aff Unit) -> Aff Unit
   withCleanEnv action = do

app/test/App/CLI/Purs.purs

@@ -2,12 +2,17 @@ module Test.Registry.App.CLI.Purs (spec) where
 
 import Registry.App.Prelude
 
+import Data.Argonaut.Parser as Argonaut.Parser
+import Data.Codec.Argonaut as CA
 import Data.Foldable (traverse_)
+import Data.Map as Map
 import Node.FS.Aff as FS.Aff
 import Node.Path as Path
 import Registry.App.CLI.Purs (CompilerFailure(..))
 import Registry.App.CLI.Purs as Purs
 import Registry.Foreign.Tmp as Tmp
+import Registry.PursGraph (ModuleName(..))
+import Registry.PursGraph as PursGraph
 import Registry.Test.Assert as Assert
 import Registry.Test.Utils as Utils
 import Registry.Version as Version
@@ -17,7 +22,8 @@ spec :: Spec.Spec Unit
 spec = do
   traverse_ (testVersion <<< Utils.unsafeVersion) [ "0.13.0", "0.14.0", "0.14.7", "0.15.4" ]
   traverse_ (testMissingVersion <<< Utils.unsafeVersion) [ "0.13.1", "0.13.7", "0.15.1", "0.12.0", "0.14.12345" ]
-  traverse_ testCompilationError [ Just (Utils.unsafeVersion "0.13.0"), Just (Utils.unsafeVersion "0.13.8"), Just (Utils.unsafeVersion "0.14.0"), Just (Utils.unsafeVersion "0.15.0"), Nothing ]
+  traverse_ (testCompilationError <<< map Utils.unsafeVersion) [ Just "0.13.0", Just "0.13.8", Just "0.14.0", Just "0.15.0", Nothing ]
+  traverse_ (testGraph <<< map Utils.unsafeVersion) [ Just "0.14.0", Just "0.15.0", Nothing ]
   where
   testVersion version =
     Spec.it ("Calls compiler version " <> Version.print version) do
@@ -49,3 +55,29 @@ spec = do
         Left (CompilationError [ { position: { startLine: 1, startColumn: 1 } } ]) ->
           pure unit
         _ -> Assert.fail "Should have failed with CompilationError"
+
+  testGraph version =
+    Spec.it ("Produces a graph for " <> maybe "latest" Version.print version) do
+      tmp <- Tmp.mkTmpDir
+      let moduleA = Path.concat [ tmp, "ModuleA.purs" ]
+      let moduleB = Path.concat [ tmp, "ModuleB.purs" ]
+      FS.Aff.writeTextFile UTF8 moduleA "module ModuleA where\n\nimport ModuleB\n"
+      FS.Aff.writeTextFile UTF8 moduleB "module ModuleB where\n"
+      result <- Purs.callCompiler { command: Purs.Graph { globs: [ moduleA, moduleB ] }, cwd: Nothing, version }
+      case result of
+        Left runErr -> Assert.fail $ case runErr of
+          CompilationError errs -> Purs.printCompilerErrors errs
+          UnknownError str -> str
+          MissingCompiler -> "MissingCompiler"
+        Right str -> case Argonaut.Parser.jsonParser str of
+          Left parseErr -> Assert.fail $ "Failed to parse output as JSON: " <> parseErr
+          Right json -> case CA.decode PursGraph.pursGraphCodec json of
+            Left decodeErr -> Assert.fail $ "Failed to decode JSON: " <> CA.printJsonDecodeError decodeErr
+            Right graph -> do
+              let
+                expected = Map.fromFoldable
+                  [ Tuple (ModuleName "ModuleA") { path: moduleA, depends: [ ModuleName "ModuleB" ] }
+                  , Tuple (ModuleName "ModuleB") { path: moduleB, depends: [] }
+                  ]
+
+              graph `Assert.shouldEqual` expected

lib/src/Operation/Validation.purs

@@ -97,6 +97,23 @@ getUnresolvedDependencies (Manifest { dependencies }) resolutions =
         | not (Range.includes dependencyRange version) -> Just $ Right $ dependencyName /\ dependencyRange /\ version
         | otherwise -> Nothing
 
+-- | Discovers dependencies listed in the manifest that are not actually used
+-- | by the solved dependencies. This should not produce an error, but it
+-- | indicates an over-constrained manifest.
+getUnusedDependencies :: Manifest -> Map PackageName Version -> Set PackageName -> Maybe (NonEmptySet PackageName)
+getUnusedDependencies (Manifest { dependencies }) resolutions discovered = do
+  let
+    -- There may be too many resolved dependencies because the manifest includes
+    -- e.g. test dependencies, so we start by only considering resolved deps
+    -- that are actually used.
+    inUse = Set.filter (flip Set.member discovered) (Map.keys resolutions)
+
+    -- Next, we can determine which dependencies are unused by looking at the
+    -- difference between the manifest dependencies and the resolved packages
+    unused = Set.filter (not <<< flip Set.member inUse) (Map.keys dependencies)
+
+  NonEmptySet.fromSet unused
+
 data TarballSizeResult
   = ExceedsMaximum Number
   | WarnPackageSize Number

lib/src/PursGraph.purs

@@ -0,0 +1,90 @@
+-- | A module describing the output of 'purs graph' along with some helper
+-- | functions for working with the graph.
+module Registry.PursGraph where
+
+import Prelude
+
+import Data.Array as Array
+import Data.Array.NonEmpty (NonEmptyArray)
+import Data.Array.NonEmpty as NonEmptyArray
+import Data.Bifunctor (bimap)
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CA.Record
+import Data.Either (Either(..))
+import Data.Map (Map)
+import Data.Map as Map
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype, un)
+import Data.Profunctor as Profunctor
+import Data.Set (Set)
+import Data.Set as Set
+import Data.Traversable (traverse)
+import Data.Tuple (Tuple(..))
+import Node.Path (FilePath)
+import Registry.Internal.Codec as Internal.Codec
+import Registry.PackageName (PackageName)
+
+-- | A graph of the dependencies between modules, discovered by the purs
+-- | compiler from a set of source files.
+type PursGraph = Map ModuleName PursGraphNode
+
+pursGraphCodec :: JsonCodec PursGraph
+pursGraphCodec = Internal.Codec.strMap "PursGraph" (Just <<< ModuleName) (un ModuleName) pursGraphNodeCodec
+
+type PursGraphNode =
+  { depends :: Array ModuleName
+  , path :: FilePath
+  }
+
+pursGraphNodeCodec :: JsonCodec PursGraphNode
+pursGraphNodeCodec = CA.Record.object "PursGraphNode"
+  { depends: CA.array moduleNameCodec
+  , path: CA.string
+  }
+
+-- | A module name string from a 'purs graph' invocation.
+newtype ModuleName = ModuleName String
+
+derive instance Newtype ModuleName _
+derive instance Eq ModuleName
+derive instance Ord ModuleName
+
+moduleNameCodec :: JsonCodec ModuleName
+moduleNameCodec = Profunctor.wrapIso ModuleName CA.string
+
+type AssociatedError = { module :: ModuleName, path :: FilePath, error :: String }
+
+-- | Given a function to parse the `path` component of `purs graph`, associate
+-- | all associate all modules in the groph with their package names.
+associateModules :: (FilePath -> Either String PackageName) -> PursGraph -> Either (NonEmptyArray AssociatedError) (Map ModuleName PackageName)
+associateModules parse graph = do
+  let
+    parsed :: Array (Either AssociatedError (Tuple ModuleName PackageName))
+    parsed = Map.toUnfoldableUnordered graph # map \(Tuple moduleName { path }) -> parse path # bimap
+      (\error -> { module: moduleName, path, error })
+      (\packageName -> Tuple moduleName packageName)
+
+    separated :: { errors :: Array AssociatedError, values :: Array (Tuple ModuleName PackageName) }
+    separated = parsed # Array.foldMap case _ of
+      Left err -> { errors: [ err ], values: [] }
+      Right tup -> { errors: [], values: [ tup ] }
+
+  case NonEmptyArray.fromArray separated.errors of
+    Nothing -> pure $ Map.fromFoldable separated.values
+    Just errors -> Left errors
+
+-- | Find direct dependencies of the given module, according to the given graph.
+directDependencies :: ModuleName -> PursGraph -> Maybe (Set ModuleName)
+directDependencies name = map (Set.fromFoldable <<< _.depends) <<< Map.lookup name
+
+-- | Find all dependencies of the given module, according to the given graph.
+allDependencies :: ModuleName -> PursGraph -> Maybe (Set ModuleName)
+allDependencies start graph = map Set.fromFoldable (getDependencies start)
+  where
+  getDependencies name =
+    map _.depends (Map.lookup name graph) >>= case _ of
+      [] -> pure []
+      directs -> do
+        let nextDeps = map Array.concat (traverse getDependencies directs)
+        nextDeps <> Just directs

lib/test/Registry.purs

@@ -12,6 +12,7 @@ import Test.Registry.Operation as Test.Operation
 import Test.Registry.Operation.Validation as Test.Operation.Validation
 import Test.Registry.PackageName as Test.PackageName
 import Test.Registry.PackageSet as Test.PackageSet
+import Test.Registry.PursGraph as Test.PursGraph
 import Test.Registry.Range as Test.Range
 import Test.Registry.SSH as Test.SSH
 import Test.Registry.Sha256 as Test.Sha256
@@ -40,3 +41,4 @@ main = Aff.launchAff_ $ Spec.Runner.runSpec [ Spec.Reporter.consoleReporter ] do
   Spec.describe "ManifestIndex" Test.ManifestIndex.spec
   Spec.describe "Solver" Test.Solver.spec
   Spec.describe "Operation Validation" Test.Operation.Validation.spec
+  Spec.describe "Purs Graph" Test.PursGraph.spec