diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,17 @@ +0.2.0.0 +======= + +- Add support for mixing in package databases from stack snapshots. +- "stack" is now a reserved name when creating sandboxes. + + +0.1.0.1 +======= + +- Loosen version constraints. + + 0.1.0.0 ======= - Initial release. - diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -30,6 +30,8 @@ import Sandman.PackageDb import Sandman.Util +import qualified Sandman.Stack as Stack + ------------------------------------------------------------------------------ -- | Main context for the program. -- @@ -220,6 +222,8 @@ ------------------------------------------------------------------------------ new :: Maybe FilePath -> Text -> IO () new ghcPath' name = do + when (name == "stack") $ + die "Sandbox 'stack' could not be created. That name is reserved." ghcPath <- maybe (return Nothing) (fmap Just . resolveExecutable) ghcPath' @@ -281,11 +285,8 @@ mix packageNames includeExecutables name = do currentPackageDb <- determinePackageDb "." >>= either fail return - sandman <- defaultSandman - sandbox <- getSandbox sandman name - >>= maybe (die $ "Sandbox " <> name <> " does not exist.") return - sandboxPackageDb <- determinePackageDb (sandboxRoot sandbox) - >>= either fail return + (sandboxPackageDb, basePackageDb, copyExecutables, getGhcPath) <- + getSandboxAndBasePackageDb let sandboxPackageNames = Set.fromList . map installedPackageName $ packageDbInstalledPackages sandboxPackageDb @@ -295,11 +296,10 @@ unless (requestedPackage `Set.member` sandboxPackageNames) $ die $ requestedPackage <> " is not installed in " <> name - basePackageIds <- getPackageGhcPath (sandboxRoot sandbox) - >>= getBasePackageDb >>= either fail return - <&> map installedPackageId . packageDbInstalledPackages + let basePackageIds = map installedPackageId + $ packageDbInstalledPackages basePackageDb - let -- Returns True if another package with the same name has already been + -- Returns True if another package with the same name has already been -- installed to the target sandbox isAlreadyInstalled = (`Set.member` alreadyInstalled) . installedPackageName @@ -397,16 +397,10 @@ newPath = currentPackageDbRoot takeFileName currentPath copyFile currentPath newPath - executables <- listDirectory (sandboxRoot sandbox "bin") - when (includeExecutables && not (null executables)) $ do - let newBinDir = takeDirectory currentPackageDbRoot "bin" - createDirectoryIfMissing True newBinDir - forM_ executables $ \exec -> do - let newPath = newBinDir takeFileName exec - alreadyExists <- doesFileExist newPath - unless alreadyExists $ copyFile exec newPath + -- Copy executables to bin/ directory if requested. + copyExecutables $ takeDirectory currentPackageDbRoot "bin" - ghcPath <- getPackageGhcPath (sandboxRoot sandbox) + ghcPath <- getGhcPath case ghcPath of Nothing -> return () Just path -> do @@ -415,7 +409,56 @@ putStrLn "Rebuilding package cache." Proc.callProcess "cabal" ["sandbox", "hc-pkg", "recache"] + where + getSandboxAndBasePackageDb + | name == "stack" = do + sandboxPackageDb <- Stack.getSnapshotPackageDb Nothing + >>= either fail return + basePackageDb <- Stack.getGlobalPackageDb + >>= either fail return + let copyExecutables _ = when includeExecutables . die $ T.unwords + [ "Copying executables for stack snapshots is" + , "not supported." + ] + getGhcPath = Just <$> Stack.getGhcPath + + return + ( sandboxPackageDb + , basePackageDb + , copyExecutables + , getGhcPath + ) + + | otherwise = do + sandman <- defaultSandman + sandbox <- getSandbox sandman name + >>= maybe (die $ "Sandbox " <> name <> " does not exist.") + return + sandboxPackageDb <- determinePackageDb (sandboxRoot sandbox) + >>= either fail return + basePackageDb <- getPackageGhcPath (sandboxRoot sandbox) + >>= getBasePackageDb + >>= either fail return + + let binDir = sandboxRoot sandbox "bin" + + copyExecutables newBinDir = do + executables <- listDirectory binDir + when (includeExecutables && not (null executables)) $ do + createDirectoryIfMissing True newBinDir + forM_ executables $ \exec -> do + let newPath = newBinDir takeFileName exec + alreadyExists <- doesFileExist newPath + unless alreadyExists $ copyFile exec newPath + + return + ( sandboxPackageDb + , basePackageDb + , copyExecutables + , getPackageGhcPath (sandboxRoot sandbox) + ) + ------------------------------------------------------------------------------ clean :: IO () clean = do @@ -469,7 +512,11 @@ destroy <$> nameArgument , command "install" "Install a new package" $ install <$> nameArgument <*> packagesArgument - , command "mix" "Mix a sandman sandbox into the current project" $ + , command "mix" + (unwords + [ "Mix a sandman sandbox into the current project." + , "Use the name 'stack' to mix in packages from stack snapshots." + ]) $ mix <$> many (T.pack <$> packageNameOption) <*> includeExecutablesOption <*> nameArgument diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -109,6 +109,21 @@ $ ls .cabal-sandbox/bin hspec-discover +# Stack + +`sandman` also supports mixing in packages from a [`stack`] snapshot package +database. + + $ sandman mix stack + +This mixes in all packages from the default snapshot database into the current +Cabal sandbox. The `-o/--only` options may be used to limit the packages to a +minimal subset. + + $ sandman mix stack -o text + + [`stack`]: https://github.com/commercialhaskell/stack + # Status Sandman is stable enough for basic use cases but there are surely a lot of diff --git a/Sandman/Stack.hs b/Sandman/Stack.hs new file mode 100644 --- /dev/null +++ b/Sandman/Stack.hs @@ -0,0 +1,42 @@ +module Sandman.Stack + ( getSnapshotPackageDb + , getGlobalPackageDb + , getGhcPath + , Resolver + ) where + +import Data.Char (isSpace) + +import qualified Data.List as L +import qualified System.Process as Proc + +import Sandman.PackageDb (PackageDb, getPackageDb) +import Sandman.Util + +type Resolver = String + +-- | Gets the package database for a stack snapshot. +-- +-- A resolver may be optionally specified. +getSnapshotPackageDb :: Maybe Resolver -> IO (Either String PackageDb) +getSnapshotPackageDb resolver = + Proc.readProcess "stack" args "" + <&> L.dropWhileEnd isSpace . L.dropWhile isSpace + >>= getPackageDb + where + resolverArgs = case resolver of + Nothing -> [] + Just re -> ["--resolver", re] + args = resolverArgs ++ ["path", "--snapshot-pkg-db"] + + +getGlobalPackageDb :: IO (Either String PackageDb) +getGlobalPackageDb = + Proc.readProcess "stack" ["path", "--global-pkg-db"] "" + <&> L.dropWhileEnd isSpace . L.dropWhile isSpace + >>= getPackageDb + +getGhcPath :: IO FilePath +getGhcPath = + Proc.readProcess "stack" ["exec", "which", "ghc"] "" + <&> L.dropWhileEnd isSpace . L.dropWhile isSpace diff --git a/sandman.cabal b/sandman.cabal --- a/sandman.cabal +++ b/sandman.cabal @@ -1,5 +1,5 @@ name : sandman -version : 0.1.0.1 +version : 0.2.0.0 synopsis : Manages Cabal sandboxes to avoid rebuilding packages. homepage : https://github.com/abhinav/sandman license : MIT @@ -25,6 +25,7 @@ main-is : Main.hs other-modules : Sandman.InstalledPackage , Sandman.PackageDb + , Sandman.Stack , Sandman.Util build-depends : base >= 4.7 && < 4.9