diff --git a/codex.cabal b/codex.cabal --- a/codex.cabal +++ b/codex.cabal @@ -1,7 +1,7 @@ name: codex -version: 0.2.1.4 +version: 0.2.1.6 synopsis: A ctags file generator for cabal project dependencies. -description: +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. . @@ -28,18 +28,19 @@ Codex Codex.Project Codex.Internal + Distribution.Sandbox.Utils other-modules: Network.Curl.DownloadLazy - build-depends: + build-depends: base >= 4.6.0.1 && < 5 , bytestring >= 0.10.0.2 && < 0.11 - , Cabal >= 1.18 && < 1.21 + , Cabal >= 1.18 && < 1.23 , containers >= 0.5.0.0 && < 0.6 , curl >= 1.3.8 && < 1.4 , directory >= 1.2.0.1 && < 1.3 , either >= 4.3.0.1 && < 4.4 , filepath >= 1.3.0.1 && < 1.4 - , hackage-db >= 1.8 && < 1.12 + , hackage-db >= 1.8 && < 2 , machines >= 0.2 && < 0.5 , machines-directory >= 0.0.0.2 && < 0.3 , MissingH >= 1.2.1.0 && < 1.4 @@ -54,12 +55,12 @@ hs-source-dirs: codex main-is: Main.hs ghc-options: -threaded -fwarn-incomplete-patterns - other-modules: + other-modules: Main.Config Main.Config.Codex0 Main.Config.Codex1 Main.Config.Codex2 - build-depends: + build-depends: base , Cabal , bytestring @@ -70,7 +71,7 @@ , MissingH , monad-loops >= 0.4.2 && < 0.5 , yaml >= 0.8.8.3 && < 0.9 - , codex == 0.2.1.4 + , codex == 0.2.1.6 source-repository head type: git diff --git a/codex/Main.hs b/codex/Main.hs --- a/codex/Main.hs +++ b/codex/Main.hs @@ -36,7 +36,7 @@ cleanCache cx = do -- TODO Delete hash file! xs <- listDirectory hp - ys <- fmap (rights) $ traverse (safe . listDirectory) xs + ys <- fmap rights $ traverse (safe . listDirectory) xs zs <- traverse (safe . removeFile) . fmap ( "tags") $ concat ys return () where hp = hackagePath cx @@ -61,7 +61,7 @@ projectHash <- computeCurrentProjectHash cx shouldUpdate <- - if (null workspaceProjects') then + if null workspaceProjects' then either (const True) id <$> (runEitherT $ isUpdateRequired cx dependencies projectHash) else return True @@ -72,18 +72,18 @@ when fileExist $ removeFile tagsFile putStrLn $ concat ["Updating ", display project] results <- traverse (retrying 3 . runEitherT . getTags) dependencies - traverse (putStrLn . show) . concat $ lefts results + traverse print . concat $ lefts results res <- runEitherT $ assembly cx dependencies projectHash workspaceProjects tagsFile - either (putStrLn . show) (const $ return ()) res + either print (const $ return ()) res else putStrLn "Nothing to update." where tagsFile = tagsFileName cx getTags i = status cx i >>= \x -> case x of (Source Tagged) -> return () - (Source Untagged) -> tags cx i >>= (const $ getTags i) - (Archive) -> extract cx i >>= (const $ getTags i) - (Remote) -> fetch cx i >>= (const $ getTags i) + (Source Untagged) -> tags cx i >> getTags i + (Archive) -> extract cx i >> getTags i + (Remote) -> fetch cx i >> getTags i help :: IO () help = putStrLn $ diff --git a/src/Codex.hs b/src/Codex.hs --- a/src/Codex.hs +++ b/src/Codex.hs @@ -1,6 +1,7 @@ module Codex (Codex(..), defaultTagsFileName, Verbosity, module Codex) where import Control.Exception (try, SomeException) +import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Either @@ -77,7 +78,7 @@ computeCurrentProjectHash :: Codex -> IO String computeCurrentProjectHash cx = if not $ currentProjectIncluded cx then return "*" else do - xs <- runT $ (autoM getModificationTime) <~ (filtered p)<~ files <~ directoryWalk <~ source ["."] + xs <- runT $ (autoM getModificationTime) <~ (filtered p) <~ files <~ directoryWalk <~ source ["."] return . md5s . Str . show $ maximum xs where p fp = any (\f -> f fp) (fmap List.isSuffixOf extensions) @@ -89,7 +90,7 @@ if fileExist then do content <- tryIO $ TLIO.readFile file let hash = TextL.toStrict . TextL.drop 17 . head . drop 2 $ TextL.lines content - return $ hash /= (Text.pack $ tagsFileHash cx ds ph) + return $ hash /= Text.pack (tagsFileHash cx ds ph) else return True where @@ -126,12 +127,12 @@ assembly :: Codex -> [PackageIdentifier] -> String -> [WorkspaceProject] -> FilePath -> Action FilePath assembly cx dependencies projectHash workspaceProjects o = do - xs <- fmap (join . maybeToList) $ projects workspaceProjects - tryIO $ mergeTags ((fmap tags dependencies) ++ xs) o + xs <- join . maybeToList <$> projects workspaceProjects + tryIO $ mergeTags (fmap tags dependencies ++ xs) o return o where projects [] = return Nothing projects xs = do - tmp <- liftIO $ getTemporaryDirectory + tmp <- liftIO getTemporaryDirectory ys <- traverse (tags tmp) xs return $ Just ys where tags tmp (WorkspaceProject identifier sources) = taggerCmdRun cx sources tags where diff --git a/src/Codex/Internal.hs b/src/Codex/Internal.hs --- a/src/Codex/Internal.hs +++ b/src/Codex/Internal.hs @@ -1,11 +1,14 @@ module Codex.Internal where import Control.Arrow +import Data.Char (isSpace) import Distribution.Package import Distribution.Text import Distribution.Verbosity import System.FilePath +import qualified Data.List as L + defaultTagsFileName :: FilePath defaultTagsFileName = "codex.tags" @@ -40,3 +43,10 @@ path = concat [name, "/", name, ".tar.gz"] name = concat [display $ pkgName i, "-", display $ pkgVersion i] +removePrefix :: String -> String -> Maybe String +removePrefix prefix str = + if prefix `L.isPrefixOf` trim str + then Just $ trim $ L.drop (length prefix) $ trim str + else Nothing + where + trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace diff --git a/src/Codex/Project.hs b/src/Codex/Project.hs --- a/src/Codex/Project.hs +++ b/src/Codex/Project.hs @@ -11,6 +11,7 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Parse +import Distribution.Sandbox.Utils (findSandbox) import Distribution.Simple.Configure import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex @@ -98,19 +99,22 @@ return $ identifier <$> resolveHackageDependencies db pd resolveSandboxDependencies :: FilePath -> IO [WorkspaceProject] -resolveSandboxDependencies root = do - fileExists <- doesFileExist sourcesFile - if fileExists then readSources else return [] where +resolveSandboxDependencies root = + findSandbox root >>= maybe (return []) continue + where + continue cabalSandboxFolder = do + fileExists <- doesFileExist sourcesFile + if fileExists then readSources else return [] + where + sourcesFile = root cabalSandboxFolder "add-source-timestamps" readSources = do fileContent <- readFile sourcesFile xs <- traverse readWorkspaceProject $ projects fileContent return $ xs >>= maybeToList where projects :: String -> [FilePath] - projects x = sources x >>= (\x -> fmap fst $ snd x) + projects x = sources x >>= (\x -> fst <$> snd x) sources :: String -> [(String, [(FilePath, Int)])] sources x = read x - sourcesFile = root ".cabal-sandbox" "add-source-timestamps" - resolveWorkspaceDependencies :: Workspace -> GenericPackageDescription -> [WorkspaceProject] resolveWorkspaceDependencies (Workspace ws) pd = maybeToList . resolveDependency =<< allDependencies pd where diff --git a/src/Distribution/Sandbox/Utils.hs b/src/Distribution/Sandbox/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Sandbox/Utils.hs @@ -0,0 +1,34 @@ +module Distribution.Sandbox.Utils where + +import Control.Applicative ((<$>)) +import System.Directory (doesFileExist) +import System.FilePath (()) +import System.IO (readFile) +import Data.Maybe (mapMaybe, listToMaybe) + +import Codex.Internal + +findSandbox :: FilePath -> IO (Maybe FilePath) +findSandbox prjDir = do + fileExists <- doesFileExist configFile + if fileExists then readSandboxDir else return Nothing where + readSandboxDir = do + fileContent <- readFile configFile + return $ removePrefixMany $ lines fileContent + configFile = prjDir "cabal.sandbox.config" + removePrefixMany = maybeFunctionMany $ removePrefix "prefix:" + maybeFunctionMany :: (a -> Maybe b) -> [a] -> Maybe b + maybeFunctionMany func list = listToMaybe $ mapMaybe func list + +readSandboxSources :: FilePath -> IO [FilePath] +readSandboxSources sandboxPath = do + fileExists <- doesFileExist sourcesFile + if fileExists then readSources else return [] where + readSources = do + fileContent <- readFile sourcesFile + return $ projects fileContent where + projects :: String -> [FilePath] + projects x = sources x >>= (\x -> fmap fst $ snd x) + sources :: String -> [(String, [(FilePath, Int)])] + sources x = read x + sourcesFile = sandboxPath "add-source-timestamps"