filesystem search stops at .git successfully

Author: peterbecich

src/Spago/Config.purs

@@ -180,7 +180,7 @@ type PrelimWorkspace =
 -- | packages to be integrated in the package set
 readWorkspace :: ∀ a. ReadWorkspaceOptions -> Spago (Registry.RegistryEnv a) Workspace
 readWorkspace { maybeSelectedPackage, pureBuild, migrateConfig } = do
-  logInfo "Reading Spago workspace configuration..."
+  logInfo "Reading spago.yaml..."
 
   let
     doMigrateConfig :: FilePath -> _ -> Spago (Registry.RegistryEnv _) Unit
@@ -196,40 +196,46 @@ readWorkspace { maybeSelectedPackage, pureBuild, migrateConfig } = do
     higherPaths :: List FilePath
     higherPaths = Array.toUnfoldable $ Paths.toGitSearchPath Paths.cwd
 
-    checkForWorkspace :: forall a. FilePath
-      -> Spago (LogEnv a) (Maybe PrelimWorkspace)
+    checkForWorkspace :: forall b. FilePath
+      -> Spago (LogEnv b) (Maybe PrelimWorkspace)
     checkForWorkspace config = do
-      logInfo $ "Checking for workspace: " <> config
+      logDebug $ "Checking for workspace: " <> config
       result <- map (map (\y -> y.yaml)) $ readConfig config
       case result of
         Left _ -> pure Nothing
         Right { workspace: Nothing } -> pure Nothing
         Right { workspace: Just ws } -> pure (Just ws)
 
-    searchHigherPaths :: forall a. List FilePath -> Spago (LogEnv a) (Maybe (Tuple FilePath PrelimWorkspace))
+    searchHigherPaths :: forall c. List FilePath -> Spago (LogEnv c) (Maybe (Tuple FilePath PrelimWorkspace))
     searchHigherPaths Nil = pure Nothing
     searchHigherPaths (path : otherPaths) = do
-      mGitRoot :: Maybe String <- map Array.head $ liftAff $ Glob.gitignoringGlob path [ "./.git" ]
-      mYaml :: Maybe String <- map (map (\yml -> path <> yml)) $ map Array.head $ liftAff $ Glob.gitignoringGlob path [ "./spago.yaml" ]
-      case mYaml of
-        Nothing -> case mGitRoot of
-          Nothing -> searchHigherPaths otherPaths
-          Just gitRoot  -> do
-            -- directory containing .git assumed to be the root of the project;
-            -- do not search up the file tree further than this
-            logInfo $ "No Spago workspace found in any directory up to root of project: " <> gitRoot
-            pure Nothing
-        Just foundSpagoYaml -> do
-          mWorkspace :: Maybe PrelimWorkspace <- checkForWorkspace foundSpagoYaml
+      mGitRoot :: Maybe String <- map Array.head $ liftAff $ Glob.findGitGlob path
+      case mGitRoot of
+        Nothing -> logDebug $ "No project root (.git) found at: " <> path
+        Just gitRoot -> logInfo $ "Project root (.git) found at: " <> path <> gitRoot
+      mSpagoYaml :: Maybe String <- map (map (\yml -> path <> yml)) $ map Array.head $ liftAff $ Glob.gitignoringGlob path [ "./spago.yaml" ]
+
+      case Tuple mSpagoYaml mGitRoot of
+        Tuple Nothing Nothing -> searchHigherPaths otherPaths
+        Tuple Nothing (Just gitRoot) -> do
+          -- directory containing .git assumed to be the root of the project;
+          -- do not search up the file tree further than this
+          logInfo $ "No Spago workspace found in any directory up to project root: " <> path <> gitRoot
+          pure Nothing
+        Tuple (Just spagoYaml) (Just gitRoot) -> do
+          mWorkspace :: Maybe PrelimWorkspace <- checkForWorkspace spagoYaml
           case mWorkspace of
-            Nothing -> case mGitRoot of
-              Nothing -> searchHigherPaths otherPaths
-              Just gitRoot  -> do
-                -- directory containing .git assumed to be the root of the project;
-                -- do not search up the file tree further than this
-                logInfo $ "No Spago workspace found in any directory up to root of project: " <> gitRoot
-                pure Nothing
-            Just ws -> pure (pure (Tuple foundSpagoYaml ws))
+            Nothing -> do
+              -- directory containing .git assumed to be the root of the project;
+              -- do not search up the file tree further than this
+              logInfo $ "No Spago workspace found in any directory up to project root: " <> path <> gitRoot
+              pure Nothing
+            Just ws -> pure (pure (Tuple spagoYaml ws))
+        Tuple (Just spagoYaml) Nothing -> do
+          mWorkspace :: Maybe PrelimWorkspace <- checkForWorkspace spagoYaml
+          case mWorkspace of
+            Nothing -> searchHigherPaths otherPaths
+            Just ws -> pure (pure (Tuple spagoYaml ws))
 
   -- First try to read the config in the root.
   -- Else, look for a workspace in parent directories.
@@ -244,7 +250,9 @@ readWorkspace { maybeSelectedPackage, pureBuild, migrateConfig } = do
         , toDoc "The configuration file help can be found here https://github.com/purescript/spago#the-configuration-file"
         ]
     Right config@{ yaml: { workspace: Nothing, package }, doc } -> do
-      logInfo "Looking for Spago workspace configuration higher in the filesystem, up to project root (.git)..."
+      logInfo
+        $ "Looking for Spago workspace configuration higher in the filesystem. Search limited to "
+          <> show Paths.gitSearchDepth <> " levels, or project root (.git)..."
       mHigherWorkspace <- searchHigherPaths higherPaths
       case mHigherWorkspace of
         Nothing ->
@@ -255,15 +263,15 @@ readWorkspace { maybeSelectedPackage, pureBuild, migrateConfig } = do
           , "See the relevant documentation here: https://github.com/purescript/spago#the-workspace"
           ]
         Just (Tuple higherWorkspacePath higherWorkspace) -> do
-          logInfo $ "Found workspace definition in " <> higherWorkspacePath
+          logInfo $ "Found workspace definition in: " <> higherWorkspacePath
           -- TODO migrate workspace at higher directory?
           doMigrateConfig "spago.yaml" config
           pure { workspace: higherWorkspace, package, workspaceDoc: doc }
     Right config@{ yaml: { workspace: Just workspace, package }, doc } -> do
       doMigrateConfig "spago.yaml" config
       pure { workspace, package, workspaceDoc: doc }
 
-  logDebug "Gathering all the spago configs lower in the tree..."
+  logDebug "Gathering all the spago configs lower in the filesystem..."
   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) ]

src/Spago/Glob.purs

@@ -3,7 +3,7 @@
 -- | All of this code (and the FFI file) is a series of attempts to make globbing
 -- | reasonably performant while still supporting all of our usecases, like ignoring
 -- | files based on `.gitignore` files.
-module Spago.Glob (gitignoringGlob) where
+module Spago.Glob (gitignoringGlob, findGitGlob) where
 
 import Spago.Prelude
 
@@ -207,3 +207,7 @@ fsWalk cwd ignorePatterns includePatterns = Aff.makeAff \cb -> do
 gitignoringGlob :: String -> Array String -> Aff (Array String)
 gitignoringGlob dir patterns = map (withForwardSlashes <<< Path.relative dir <<< _.path)
   <$> fsWalk dir [ ".git" ] patterns
+
+findGitGlob :: String -> Aff (Array String)
+findGitGlob dir = map (withForwardSlashes <<< Path.relative dir <<< _.path)
+  <$> fsWalk dir mempty [ "./.git" ]

src/Spago/Paths.purs

@@ -41,8 +41,10 @@ toLocalCachePackagesPath :: FilePath -> FilePath
 toLocalCachePackagesPath rootDir = Path.concat [ toLocalCachePath rootDir, "p" ]
 
 -- search maximum 4 levels up the tree to find all other `spago.yaml`, which may contain workspace definition
+gitSearchDepth :: Int
+gitSearchDepth = 4
 toGitSearchPath :: FilePath -> Array FilePath
-toGitSearchPath rootDir = reverse $ makeSearchPaths rootDir 4 where
+toGitSearchPath rootDir = reverse $ makeSearchPaths rootDir gitSearchDepth where
   makeSearchPath :: FilePath -> Int -> FilePath
   makeSearchPath wd i = joinWith "" $ cons wd $ cons "/" $ replicate i "../"