sandman 0.1.0.1 → 0.2.0.0
raw patch · 5 files changed
+138/−21 lines, 5 files
Files
- CHANGES.md +13/−1
- Main.hs +66/−19
- README.md +15/−0
- Sandman/Stack.hs +42/−0
- sandman.cabal +2/−1
CHANGES.md view
@@ -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.-
Main.hs view
@@ -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
README.md view
@@ -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
+ Sandman/Stack.hs view
@@ -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
sandman.cabal view
@@ -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