diff --git a/codex.cabal b/codex.cabal --- a/codex.cabal +++ b/codex.cabal @@ -1,11 +1,11 @@ name: codex -version: 0.3.0.10 +version: 0.4.0.0 synopsis: A ctags file generator for cabal project dependencies. description: This tool download and cache the source code of packages in your local hackage, - it can then use this cache to generate `tags` files aggregating the sources of all the dependencies of your cabal projects. + it can then use this cache to generate `tags` files aggregating the sources of all the dependencies of your cabal/stack projects. . - You basically do `codex update` in your cabal project directory and you'll get a file + You basically do `codex update` in your project directory and you'll get a file (`codex.tags` by default, or `TAGS` when using emacs format) that you can use in your favorite text editor. . @@ -62,6 +62,7 @@ Main.Config.Codex0 Main.Config.Codex1 Main.Config.Codex2 + Paths_codex build-depends: base , Cabal @@ -71,12 +72,12 @@ , filepath , hackage-db , MissingH - , yaml , monad-loops >= 0.4.2 && < 0.5 , network >= 2.6 && < 2.7 + , process , wreq , yaml - , codex == 0.3.0.10 + , codex == 0.4.0.0 source-repository head type: git diff --git a/codex/Main.hs b/codex/Main.hs --- a/codex/Main.hs +++ b/codex/Main.hs @@ -18,11 +18,13 @@ import Paths_codex (version) import System.Directory import System.Environment -import System.FilePath import System.Exit +import System.FilePath +import System.Process (shell, readCreateProcessWithExitCode) import Codex import Codex.Project +import Codex.Internal (Builder(..), hackagePathOf, readStackPath) import Main.Config -- TODO Add 'cache dump' to dump all tags in stdout (usecase: pipe to grep) @@ -62,9 +64,9 @@ writeCacheHash :: Codex -> String -> IO () writeCacheHash cx = writeFile $ hashFile cx -update :: Codex -> Bool -> IO () -update cx force = do - (project, dependencies, workspaceProjects') <- resolveCurrentProjectDependencies $ hackagePath cx "00-index.tar" +update :: Bool -> Codex -> Builder -> IO () +update force cx bldr = do + (project, dependencies, workspaceProjects') <- resolveCurrentProjectDependencies bldr $ hackagePath cx "00-index.tar" projectHash <- computeCurrentProjectHash cx shouldUpdate <- @@ -80,17 +82,18 @@ putStrLn $ concat ["Updating ", display project] results <- withSession $ \s -> traverse (retrying 3 . runEitherT . getTags s) dependencies _ <- traverse print . concat $ lefts results - res <- runEitherT $ assembly cx dependencies projectHash workspaceProjects tagsFile + res <- runEitherT $ assembly bldr cx dependencies projectHash workspaceProjects tagsFile either print (const $ return ()) res else putStrLn "Nothing to update." where tagsFile = tagsFileName cx - getTags s i = status cx i >>= \x -> case x of + hp = hackagePathOf bldr cx + getTags s i = status hp i >>= \x -> case x of Source Tagged -> return () - Source Untagged -> tags cx i >> getTags s i - Archive -> extract cx i >> getTags s i - Remote -> fetch s cx i >> getTags s i + Source Untagged -> tags bldr cx i >> getTags s i + Archive -> extract hp i >> getTags s i + Remote -> fetch s hp i >> getTags s i help :: IO () help = putStrLn $ @@ -114,8 +117,8 @@ args <- getArgs run cx args where run cx ["cache", "clean"] = cleanCache cx - run cx ["update"] = withConfig cx (\x -> update x False) - run cx ["update", "--force"] = withConfig cx (\x -> update x True) + run cx ["update"] = withConfig cx (update False) + run cx ["update", "--force"] = withConfig cx (update True) run cx ["set", "tagger", "ctags"] = encodeConfig $ cx { tagsCmd = taggerCmd Ctags } run cx ["set", "tagger", "hasktags"] = encodeConfig $ cx { tagsCmd = taggerCmd Hasktags } run cx ["set", "format", "emacs"] = encodeConfig $ cx { tagsCmd = taggerCmd HasktagsEmacs, tagsFileHeader = False, tagsFileSorted = False, tagsFileName = "TAGS" } @@ -126,20 +129,29 @@ run _ [] = help run _ args = fail' $ concat ["codex: '", intercalate " " args,"' is not a codex command. See 'codex --help'."] - withConfig cx f = checkConfig cx >>= \state -> case state of + withConfig cx' f = checkConfig cx' >>= \state -> case state of TaggerNotFound -> fail' $ "codex: tagger not found." Ready -> do + stackFileExists <- doesFileExist $ "." "stack.yaml" + (bldr, cx) <- if stackFileExists then do + (ec, _, _) <- readCreateProcessWithExitCode (shell "which stack") "" + case ec of + ExitSuccess -> do + globalPath <- readStackPath "global-stack-root" + return (Stack, cx' { hackagePath = globalPath "indices" "Hackage" }) + _ -> + return (Cabal, cx') + else return (Cabal, cx') cacheHash' <- readCacheHash cx case cacheHash' of Just cacheHash -> - when (cacheHash /= currentHash) $ do + when (cacheHash /= codexHash cx) $ do putStrLn "codex: configuration has been updated, cleaning cache ..." cleanCache cx Nothing -> return () - res <- f cx - writeCacheHash cx currentHash - return res where - currentHash = codexHash cx + res <- f cx bldr + writeCacheHash cx $ codexHash cx + return res fail' msg = do putStrLn $ msg diff --git a/src/Codex.hs b/src/Codex.hs --- a/src/Codex.hs +++ b/src/Codex.hs @@ -113,23 +113,23 @@ where file = tagsFileName cx -status :: Codex -> PackageIdentifier -> Action Status -status cx i = do - sourcesExist <- tryIO . doesDirectoryExist $ packageSources cx i - archiveExist <- tryIO . doesFileExist $ packageArchive cx i +status :: FilePath -> PackageIdentifier -> Action Status +status root i = do + sourcesExist <- tryIO . doesDirectoryExist $ packageSources root i + archiveExist <- tryIO . doesFileExist $ packageArchive root i case (sourcesExist, archiveExist) of - (True, _) -> fmap (Source . fromBool) (liftIO . doesFileExist $ packageTags cx i) + (True, _) -> fmap (Source . fromBool) (liftIO . doesFileExist $ packageTags root i) (_, True) -> return Archive (_, _) -> return Remote -fetch :: WS.Session -> Codex -> PackageIdentifier -> Action FilePath -fetch s cx i = do +fetch :: WS.Session -> FilePath -> PackageIdentifier -> Action FilePath +fetch s root i = do bs <- tryIO $ do - createDirectoryIfMissing True (packagePath cx i) + createDirectoryIfMissing True (packagePath root i) openLazyURI s url either left write bs where write bs = fmap (const archivePath) $ tryIO $ BS.writeFile archivePath bs - archivePath = packageArchive cx i + archivePath = packageArchive root i url = packageUrl i openLazyURI :: WS.Session -> String -> IO (Either String BS.ByteString) @@ -137,18 +137,19 @@ showHttpEx :: HttpException -> String showHttpEx = show -extract :: Codex -> PackageIdentifier -> Action FilePath -extract cx i = fmap (const path) . tryIO $ read' path (packageArchive cx i) where +extract :: FilePath -> PackageIdentifier -> Action FilePath +extract root i = fmap (const path) . tryIO $ read' path (packageArchive root i) where read' dir tar = Tar.unpack dir . Tar.read . GZip.decompress =<< BS.readFile tar - path = packagePath cx i + path = packagePath root i -tags :: Codex -> PackageIdentifier -> Action FilePath -tags cx i = taggerCmdRun cx sources tags' where - sources = packageSources cx i - tags' = packageTags cx i +tags :: Builder -> Codex -> PackageIdentifier -> Action FilePath +tags bldr cx i = taggerCmdRun cx sources tags' where + sources = packageSources hp i + tags' = packageTags hp i + hp = hackagePathOf bldr cx -assembly :: Codex -> [PackageIdentifier] -> String -> [WorkspaceProject] -> FilePath -> Action FilePath -assembly cx dependencies projectHash workspaceProjects o = do +assembly :: Builder -> Codex -> [PackageIdentifier] -> String -> [WorkspaceProject] -> FilePath -> Action FilePath +assembly bldr cx dependencies projectHash workspaceProjects o = do xs <- join . maybeToList <$> projects workspaceProjects tryIO $ mergeTags (fmap tags' dependencies ++ xs) o return o where @@ -164,7 +165,7 @@ let xs = concat $ fmap TextL.lines contents let ys = if sorted then (Set.toList . Set.fromList) xs else xs TLIO.writeFile o' $ TextL.unlines (concat [headers, ys]) - tags' = packageTags cx + tags' = packageTags $ hackagePathOf bldr cx headers = if tagsFileHeader cx then fmap TextL.pack [headerFormat, headerSorted, headerHash] else [] headerFormat = "!_TAG_FILE_FORMAT\t2" headerSorted = concat ["!_TAG_FILE_SORTED\t", if sorted then "1" else "0"] diff --git a/src/Codex/Internal.hs b/src/Codex/Internal.hs --- a/src/Codex/Internal.hs +++ b/src/Codex/Internal.hs @@ -8,12 +8,15 @@ import Distribution.Text import GHC.Generics import System.FilePath +import System.Process (shell, readCreateProcess) import qualified Data.List as L defaultTagsFileName :: FilePath defaultTagsFileName = "codex.tags" +data Builder = Cabal | Stack + data Codex = Codex { currentProjectIncluded :: Bool , hackagePath :: FilePath @@ -27,22 +30,26 @@ instance ToJSON Codex instance FromJSON Codex -packagePath :: Codex -> PackageIdentifier -> FilePath -packagePath cx i = hackagePath cx relativePath i where +hackagePathOf :: Builder -> Codex -> FilePath +hackagePathOf Cabal cx = hackagePath cx +hackagePathOf Stack cx = hackagePath cx "packages" + +packagePath :: FilePath -> PackageIdentifier -> FilePath +packagePath root i = root relativePath i where relativePath _ = name version where name = display $ pkgName i version = display $ pkgVersion i -packageArchive :: Codex -> PackageIdentifier -> FilePath -packageArchive cx i = packagePath cx i name where +packageArchive :: FilePath -> PackageIdentifier -> FilePath +packageArchive root i = packagePath root i name where name = concat [display $ pkgName i, "-", display $ pkgVersion i, ".tar.gz"] -packageSources :: Codex -> PackageIdentifier -> FilePath -packageSources cx i = packagePath cx i name where +packageSources :: FilePath -> PackageIdentifier -> FilePath +packageSources root i = packagePath root i name where name = concat [display $ pkgName i, "-", display $ pkgVersion i] -packageTags :: Codex -> PackageIdentifier -> FilePath -packageTags cx i = packagePath cx i "tags" +packageTags :: FilePath -> PackageIdentifier -> FilePath +packageTags root i = packagePath root i "tags" packageUrl :: PackageIdentifier -> String packageUrl i = concat ["http://hackage.haskell.org/package/", path] where @@ -56,3 +63,6 @@ else Nothing where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +readStackPath :: String -> IO String +readStackPath id' = init <$> readCreateProcess (shell ("stack path --" ++ id')) "" diff --git a/src/Codex/Project.hs b/src/Codex/Project.hs --- a/src/Codex/Project.hs +++ b/src/Codex/Project.hs @@ -17,8 +17,11 @@ import Distribution.PackageDescription.Parse import Distribution.Sandbox.Utils (findSandbox) import Distribution.Simple.Configure +import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex +import Distribution.Simple.Program (defaultProgramConfiguration) +import Distribution.Simple.Setup import Distribution.Verbosity import Distribution.Version import System.Directory @@ -27,6 +30,8 @@ import qualified Data.List as List import qualified Data.Map as Map +import Codex.Internal (Builder(..), readStackPath) + newtype Workspace = Workspace [WorkspaceProject] deriving (Eq, Show) @@ -52,16 +57,16 @@ files <- filterM (doesFileExist . () root) contents traverse (readPackageDescription silent) $ fmap (\x -> root x) $ List.find (List.isSuffixOf ".cabal") files -resolveCurrentProjectDependencies :: FilePath -> IO ProjectDependencies -resolveCurrentProjectDependencies hackagePath = do +resolveCurrentProjectDependencies :: Builder -> FilePath -> IO ProjectDependencies +resolveCurrentProjectDependencies bldr hackagePath = do ws <- getWorkspace ".." - resolveProjectDependencies ws hackagePath "." + resolveProjectDependencies bldr ws hackagePath "." -- TODO Optimize -resolveProjectDependencies :: Workspace -> FilePath -> FilePath -> IO ProjectDependencies -resolveProjectDependencies ws hackagePath root = do +resolveProjectDependencies :: Builder -> Workspace -> FilePath -> FilePath -> IO ProjectDependencies +resolveProjectDependencies bldr ws hackagePath root = do pd <- maybe (error "No cabal file found.") id <$> findPackageDescription root - xs <- resolvePackageDependencies hackagePath root pd + xs <- resolvePackageDependencies bldr hackagePath root pd ys <- resolveSandboxDependencies root let zs = resolveWorkspaceDependencies ws pd let wsds = List.filter (shouldOverride xs) $ List.nubBy (on (==) prjId) $ concat [ys, zs] @@ -71,16 +76,28 @@ maybe True (\y -> pkgVersion x >= pkgVersion y) $ List.find (\y -> pkgName x == pkgName y) xs prjId = pkgName . workspaceProjectIdentifier -resolveInstalledDependencies :: FilePath -> IO (Either SomeException [PackageIdentifier]) -resolveInstalledDependencies root = try $ do - lbi <- getPersistBuildConfig distPref +resolveInstalledDependencies :: Builder -> FilePath -> GenericPackageDescription -> IO (Either SomeException [PackageIdentifier]) +resolveInstalledDependencies bldr root pd = try $ do + lbi <- case bldr of + Cabal -> withCabal + Stack -> withStack let ipkgs = installedPkgs lbi clbis = snd <$> allComponentsInBuildOrder lbi pkgs = componentPackageDeps =<< clbis ys = (maybeToList . lookupInstalledPackageId ipkgs) =<< fmap fst pkgs xs = fmap sourcePackageId $ ys return xs where - distPref = root "dist" + withCabal = getPersistBuildConfig $ root "dist" + withStack = do + cfs <- getConfigFlags + configure (pd, emptyHookedBuildInfo) cfs + where + getConfigFlags = do + snapshotDb <- readStackPath "snapshot-pkg-db" + localDb <- readStackPath "local-pkg-db" + return $ (defaultConfigFlags defaultProgramConfiguration) { + configPackageDBs = Just . SpecificPackageDB <$> [snapshotDb, localDb] + } resolveHackageDependencies :: Hackage -> GenericPackageDescription -> [GenericPackageDescription] resolveHackageDependencies db pd = maybeToList . resolveDependency db =<< allDependencies pd where @@ -89,17 +106,17 @@ latest <- List.find (\x -> withinRange x versionRange) $ List.reverse $ List.sort $ Map.keys pdsByVersion Map.lookup latest pdsByVersion -resolvePackageDependencies :: FilePath -> FilePath -> GenericPackageDescription -> IO [PackageIdentifier] -resolvePackageDependencies hackagePath root pd = do - xs <- either (fallback pd) return =<< resolveInstalledDependencies root +resolvePackageDependencies :: Builder -> FilePath -> FilePath -> GenericPackageDescription -> IO [PackageIdentifier] +resolvePackageDependencies bldr hackagePath root pd = do + xs <- either fallback return =<< resolveInstalledDependencies bldr root pd return xs where - fallback pd' e = do + fallback e = do putStrLn $ concat ["cabal: ", show e] putStrLn "codex: *warning* falling back on dependency resolution using hackage" - resolveWithHackage pd' - resolveWithHackage pd' = do + resolveWithHackage + resolveWithHackage = do db <- readHackage' hackagePath - return $ identifier <$> resolveHackageDependencies db pd' + return $ identifier <$> resolveHackageDependencies db pd resolveSandboxDependencies :: FilePath -> IO [WorkspaceProject] resolveSandboxDependencies root =