search parent dirs for workspace

purescript#1237

src/Spago/Config.purs

@@ -38,6 +38,7 @@ import Data.Enum as Enum
 import Data.Graph as Graph
 import Data.HTTP.Method as Method
 import Data.Int as Int
+import Data.List (List(..), (:))
 import Data.Map as Map
 import Data.Nullable (Nullable)
 import Data.Nullable as Nullable
@@ -47,6 +48,7 @@ import Data.Set.NonEmpty (NonEmptySet)
 import Data.Set.NonEmpty as NonEmptySet
 import Data.String (CodePoint, Pattern(..))
 import Data.String as String
+import Data.Traversable (sequence)
 import Dodo as Log
 import Effect.Aff as Aff
 import Effect.Uncurried (EffectFn2, EffectFn3, runEffectFn2, runEffectFn3)
@@ -164,6 +166,17 @@ type ReadWorkspaceOptions =
   , migrateConfig :: Boolean
   }
 
+type PrelimWorkspace =
+  { backend :: Maybe Core.BackendConfig
+  , buildOpts :: Maybe
+                 { censorLibraryWarnings :: Maybe Core.CensorBuildWarnings
+                 , output :: Maybe String
+                 , statVerbosity :: Maybe Core.StatVerbosity
+                 }
+  , extraPackages :: Maybe (Map PackageName Core.ExtraPackage)
+  , packageSet :: Maybe Core.SetAddress
+  }
+
 -- | Reads all the configurations in the tree and builds up the Map of local
 -- | packages to be integrated in the package set
 readWorkspace :: ReadWorkspaceOptions -> Spago (Registry.RegistryEnv _) Workspace
@@ -180,6 +193,36 @@ readWorkspace { maybeSelectedPackage, pureBuild, migrateConfig } = do
         false, true -> logWarn $ "Your " <> path <> " is using an outdated format. Run Spago with the --migrate flag to update it to the latest version."
         _, false -> pure unit
 
+  logInfo "Gathering all the spago configs higher in the tree..."
+  let
+    higherPaths :: List FilePath
+    higherPaths = Array.toUnfoldable $ Paths.toGitSearchPath Paths.cwd
+
+    checkForWorkspace :: forall a. FilePath
+      -> Spago (LogEnv a) (Maybe PrelimWorkspace)
+    checkForWorkspace config = do
+      result <- readConfig config
+      case result of
+        Left _ -> pure Nothing
+        Right { yaml: { workspace: Nothing } } -> pure Nothing
+        Right { yaml: { workspace: Just ws } } -> pure (Just ws)
+
+    searchHigherPaths :: forall a. List FilePath -> Spago (LogEnv a) (Maybe PrelimWorkspace)
+    searchHigherPaths Nil = pure Nothing
+    searchHigherPaths (path : otherPaths) = do
+      mYaml :: Maybe String <- map Array.head $ liftAff $ Glob.gitignoringGlob path [ "./spago.yaml" ]
+      case mYaml of
+        Nothing -> searchHigherPaths otherPaths
+        Just foundSpagoYaml -> do
+          mWorkspace :: Maybe PrelimWorkspace <- checkForWorkspace foundSpagoYaml
+          case mWorkspace of
+            Nothing -> searchHigherPaths otherPaths
+            workspace -> pure workspace
+
+  mHigherConfigPath <- searchHigherPaths higherPaths
+  for_ mHigherConfigPath $ \higherConfigPath -> do
+    logDebug $ [ toDoc "Found workspace at higher path:" ]
+
   -- First try to read the config in the root. It _has_ to contain a workspace
   -- configuration, or we fail early.
   { workspace, package: maybePackage, workspaceDoc } <- readConfig "spago.yaml" >>= case _ of
@@ -199,10 +242,10 @@ readWorkspace { maybeSelectedPackage, pureBuild, migrateConfig } = do
       doMigrateConfig "spago.yaml" config
       pure { workspace, package, workspaceDoc: doc }
 
-  logDebug "Gathering all the spago configs in the tree..."
-  otherConfigPaths <- liftAff $ Glob.gitignoringGlob Paths.cwd [ "**/spago.yaml" ]
-  unless (Array.null otherConfigPaths) do
-    logDebug $ [ toDoc "Found packages at these paths:", Log.indent $ Log.lines (map toDoc otherConfigPaths) ]
+  logDebug "Gathering all the spago configs lower in the tree..."
+  otherLowerConfigPaths <- liftAff $ Glob.gitignoringGlob Paths.cwd [ "**/spago.yaml" ]
+  unless (Array.null otherLowerConfigPaths) do
+    logDebug $ [ toDoc "Found packages at these lower paths:", Log.indent $ Log.lines (map toDoc otherLowerConfigPaths) ]
 
   -- We read all of them in, and only read the package section, if any.
   let
@@ -220,7 +263,7 @@ readWorkspace { maybeSelectedPackage, pureBuild, migrateConfig } = do
         Right config -> do
           Right { config, hasTests, configPath: path, packagePath: Path.dirname path }
 
-  { right: otherPackages, left: failedPackages } <- partitionMap identity <$> traverse readWorkspaceConfig otherConfigPaths
+  { right: otherPackages, left: failedPackages } <- partitionMap identity <$> traverse readWorkspaceConfig otherLowerConfigPaths
   unless (Array.null failedPackages) do
     logWarn $ [ toDoc "Failed to read some configs:" ] <> failedPackages
 

src/Spago/Paths.purs

@@ -6,6 +6,8 @@ import Effect.Unsafe (unsafePerformEffect)
 import Node.Path (FilePath)
 import Node.Path as Path
 import Node.Process as Process
+import Data.Array (cons, replicate, reverse)
+import Data.String (joinWith)
 
 type NodePaths =
   { config :: FilePath
@@ -38,6 +40,17 @@ toLocalCachePath rootDir = Path.concat [ rootDir, ".spago" ]
 toLocalCachePackagesPath :: FilePath -> FilePath
 toLocalCachePackagesPath rootDir = Path.concat [ toLocalCachePath rootDir, "p" ]
 
+-- search maximum 4 levels up the tree to find the Git project, if it exists
+toGitSearchPath :: FilePath -> Array FilePath
+toGitSearchPath rootDir = reverse $ makeSearchPaths rootDir 2 where
+  makeSearchPath :: FilePath -> Int -> FilePath
+  makeSearchPath wd i = joinWith "" $ cons wd $ cons "/" $ replicate i "../"
+
+  makeSearchPaths :: FilePath -> Int -> Array FilePath
+  makeSearchPaths wd 0 = pure wd
+  makeSearchPaths wd i | i > 0 = cons (makeSearchPath wd i) (makeSearchPaths wd (i - 1))
+  makeSearchPaths _ _ = mempty
+
 registryPath ∷ FilePath
 registryPath = Path.concat [ globalCachePath, "registry" ]
 

test/Spago/Paths.purs

@@ -0,0 +1,21 @@
+module Test.Spago.Paths where
+
+import Test.Prelude
+
+import Test.Spec (Spec)
+import Test.Spec as Spec
+import Test.Spec.Assertions as Assert
+
+import Spago.Paths (toGitSearchPath)
+
+spec :: Spec Unit
+spec = Spec.around withTempDir do
+  Spec.describe "paths" do
+    Spec.it "generate four paths to parent directories of working directory, plus working directory" \ _ -> do
+      toGitSearchPath "~/a/b/c/d/e" `Assert.shouldEqual`
+        [ "~/a/b/c/d/e"
+        , "~/a/b/c/d/e/../"
+        , "~/a/b/c/d/e/../../"
+        , "~/a/b/c/d/e/../../../"
+        , "~/a/b/c/d/e/../../../../"
+        ]