Have "stack init" accept a list of sub-directories

src/Stack/Init.hs

@@ -13,15 +13,15 @@ import           Control.Monad
 import           Control.Monad.Catch             (MonadMask, throwM)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
-import           Control.Monad.Reader            (asks, MonadReader)
+import           Control.Monad.Reader            (MonadReader, asks)
 import           Control.Monad.Trans.Control     (MonadBaseControl)
 import qualified Data.ByteString.Builder         as B
-import qualified Data.ByteString.Lazy            as L
 import qualified Data.ByteString.Char8           as BC
+import qualified Data.ByteString.Lazy            as L
+import qualified Data.Foldable                   as F
 import           Data.Function                   (on)
 import qualified Data.HashMap.Strict             as HM
 import qualified Data.IntMap                     as IntMap
-import qualified Data.Foldable                   as F
 import           Data.List                       (intersect, maximumBy)
 import           Data.List.Extra                 (nubOrd)
 import           Data.Map                        (Map)
@@ -35,13 +35,13 @@ import           Network.HTTP.Client.Conduit     (HasHttpManager)
 import           Path
 import           Path.IO
 import           Stack.BuildPlan
+import           Stack.Config                    (getSnapshots,
+                                                  makeConcreteResolver)
 import           Stack.Constants
 import           Stack.Solver
 import           Stack.Types
-import           Stack.Types.Internal            ( HasTerminal, HasReExec
-                                                 , HasLogLevel)
-import           Stack.Config                    ( getSnapshots
-                                                 , makeConcreteResolver)
+import           Stack.Types.Internal            (HasLogLevel, HasReExec,
+                                                  HasTerminal)
 import qualified System.FilePath                 as FP
 
 -- | Generate stack.yaml
@@ -57,8 +57,8 @@ initProject
 initProject currDir initOpts mresolver = do
     let dest = currDir </> stackDotYaml
 
+    dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)
     reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest
-
     exists <- doesFileExist dest
     when (not (forceOverwrite initOpts) && exists) $ do
         error ("Stack configuration file " <> reldest <>
@@ -67,8 +67,12 @@ initProject currDir initOpts mresolver = do
 
     let noPkgMsg =  "In order to init, you should have an existing .cabal \
                     \file. Please try \"stack new\" instead."
-
-    cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir
+    let findCabalFiles' = findCabalFiles (includeSubDirs initOpts)
+    cabalfps <- if null dirs
+                then
+                   findCabalFiles' currDir
+                else
+                  liftM concat $ mapM findCabalFiles' dirs
     (bundle, dupPkgs)  <- cabalPackagesCheck cabalfps noPkgMsg Nothing
 
     (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts
@@ -435,12 +439,14 @@ getRecommendedSnapshots snapshots = do
         ]
 
 data InitOpts = InitOpts
-    { useSolver :: Bool
+    { useSolver      :: Bool
     -- ^ Use solver to determine required external dependencies
-    , omitPackages :: Bool
+    , omitPackages   :: Bool
     -- ^ Exclude conflicting or incompatible user packages
     , forceOverwrite :: Bool
     -- ^ Overwrite existing stack.yaml
     , includeSubDirs :: Bool
     -- ^ If True, include all .cabal files found in any sub directories
+    , searchDirs     :: ![T.Text]
+    -- ^ List of sub directories to search for .cabal files
     }

src/Stack/Options.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE OverloadedStrings,RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 module Stack.Options
     (BuildCommand(..)
@@ -26,32 +27,32 @@ module Stack.Options
     ,globalOptsFromMonoid
     ) where
 
-import           Control.Monad.Logger (LogLevel(..))
-import           Data.Char (isSpace, toLower)
-import           Data.List (intercalate)
-import           Data.List.Split (splitOn)
-import qualified Data.Map as Map
-import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
+import           Control.Monad.Logger              (LogLevel (..))
+import           Data.Char                         (isSpace, toLower)
+import           Data.List                         (intercalate)
+import           Data.List.Split                   (splitOn)
+import qualified Data.Map                          as Map
+import           Data.Map.Strict                   (Map)
+import qualified Data.Map.Strict                   as M
 import           Data.Maybe
 import           Data.Monoid
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import           Data.Text.Read (decimal)
-import           Distribution.Version (anyVersion)
+import qualified Data.Set                          as Set
+import qualified Data.Text                         as T
+import           Data.Text.Read                    (decimal)
+import           Distribution.Version              (anyVersion)
 import           Options.Applicative
 import           Options.Applicative.Args
 import           Options.Applicative.Builder.Extra
-import           Options.Applicative.Types (fromM, oneM, readerAsk)
-import           Stack.Clean (CleanOpts(..))
-import           Stack.Config (packagesParser)
+import           Options.Applicative.Types         (fromM, oneM, readerAsk)
+import           Stack.Clean                       (CleanOpts (..))
+import           Stack.Config                      (packagesParser)
 import           Stack.ConfigCmd
-import           Stack.Constants (stackProgName)
-import           Stack.Coverage (HpcReportOpts(..))
+import           Stack.Constants                   (stackProgName)
+import           Stack.Coverage                    (HpcReportOpts (..))
 import           Stack.Docker
-import qualified Stack.Docker as Docker
+import qualified Stack.Docker                      as Docker
 import           Stack.Dot
-import           Stack.Ghci (GhciOpts(..))
+import           Stack.Ghci                        (GhciOpts (..))
 import           Stack.Init
 import           Stack.New
 import           Stack.Nix
@@ -682,7 +683,12 @@ initOptsParser :: Parser InitOpts
 initOptsParser =
     InitOpts <$> solver <*> omitPackages
              <*> overwrite <*> fmap not ignoreSubDirs
+             <*> searchDirs
   where
+    searchDirs =
+      many (textArgument
+              (metavar "DIRS" <>
+               help "Directories to include, default is current directory."))
     ignoreSubDirs = switch (long "ignore-subdirs" <>
                            help "Do not search for .cabal files in sub directories")
     overwrite = switch (long "force" <>

src/main/Main.hs

@@ -1173,8 +1173,10 @@ withMiniConfigAndLock go inner =
 -- | Project initialization
 initCmd :: InitOpts -> GlobalOpts -> IO ()
 initCmd initOpts go = do
-    pwd <- getCurrentDir
-    withMiniConfigAndLock go (initProject pwd initOpts (globalResolver go))
+    workDir <- getCurrentDir
+    withMiniConfigAndLock go $
+      initProject workDir initOpts $
+      globalResolver go
 
 -- | Create a project directory structure and initialize the stack config.
 newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO ()