codex 0.0.1.7 → 0.0.2

raw patch · 5 files changed

+122/−76 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• codex.cabal +1/−1
• src/Codex.hs +29/−15
• src/Codex/Project.hs +68/−12
• src/Distribution/Hackage/Utils.hs +0/−26
• src/Main.hs +24/−22

@@ -1,5 +1,5 @@ name:                codex-version:             0.0.1.7+version:             0.0.2 synopsis:            A ctags file generator for cabal project dependencies. description:            This tool download and cache the source code of packages in your local hackage,

@@ -5,8 +5,9 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Either import Data.Hash.MD5+import Data.Maybe import Data.Traversable (traverse)-import Data.String.Utils+import Data.String.Utils hiding (join) import Distribution.Package import Distribution.PackageDescription import Distribution.Text@@ -25,6 +26,7 @@ import qualified Data.Text.Lazy.IO as TLIO  import Codex.Internal+import Codex.Project  -- TODO Replace the `Codex` context with a `Control.Reader.Monad `. @@ -47,6 +49,12 @@ taggerCmd Ctags = "ctags --tag-relative=no --recurse -f '$TAGS' '$SOURCES'" taggerCmd Hasktags = "hasktags --ctags --output='$TAGS' '$SOURCES'" +taggerCmdRun :: Codex -> FilePath -> FilePath -> Action FilePath+taggerCmdRun cx sources tags = do+  tryIO $ system command+  return tags where+    command = replace "$SOURCES" sources $ replace "$TAGS" tags $ tagsCmd cx+ -- TODO It would be much better to work out which `Exception`s are thrown by which operations, --      and store all of that in a ADT. For now, I'll just be lazy. tryIO :: IO a -> Action a@@ -92,21 +100,27 @@   path = packagePath cx i  tags :: Codex -> PackageIdentifier -> Action FilePath-tags cx i = do-  tryIO $ system command-  return tags where+tags cx i = taggerCmdRun cx sources tags where     sources = packageSources cx i     tags = packageTags cx i-    command = replace "$SOURCES" sources $ replace "$TAGS" tags $ tagsCmd cx -assembly :: Codex -> [PackageIdentifier] -> FilePath -> Action FilePath-assembly cx is o = tryIO . fmap (const o) $ mergeTags (fmap tags is) o where-  mergeTags files o = do-    contents <- traverse TLIO.readFile files-    let xs = List.sort . concat $ fmap TextL.lines contents-    TLIO.writeFile o $ TextL.unlines (concat [headers, xs])-  tags i = packageTags cx i-  headers :: [TextL.Text]-  headers = fmap TextL.pack ["!_TAG_FILE_FORMAT 2", "!_TAG_FILE_SORTED 1", hash]-  hash = concat ["!_TAG_FILE_CODEX ", dependenciesHash is]+assembly :: Codex -> [PackageIdentifier] -> [WorkspaceProject] -> FilePath -> Action FilePath+assembly cx dependencies workspaceProjects o = do+  xs <- fmap (join . maybeToList) $ projects workspaceProjects+  tryIO $ mergeTags ((fmap tags dependencies) ++ xs) o +  return o where+    projects [] = return Nothing+    projects xs = do+      tmp <- liftIO $ getTemporaryDirectory +      ys <- traverse (tags tmp) xs+      return $ Just ys where+        tags tmp (WorkspaceProject identifier sources) = taggerCmdRun cx sources tags where+          tags = joinPath [tmp, concat [display identifier, ".tags"]]+    mergeTags files o = do+      contents <- traverse TLIO.readFile files+      let xs = List.sort . concat $ fmap TextL.lines contents+      TLIO.writeFile o $ TextL.unlines (concat [headers, xs])+    tags i = packageTags cx i+    headers = fmap TextL.pack ["!_TAG_FILE_FORMAT 2", "!_TAG_FILE_SORTED 1", hash]+    hash = concat ["!_TAG_FILE_CODEX ", dependenciesHash dependencies] 

@@ -6,8 +6,9 @@ import Data.String.Utils import Data.Traversable (traverse) import Distribution.InstalledPackageInfo-import Distribution.Hackage.DB (readHackage)+import Distribution.Hackage.DB (Hackage, readHackage) import Distribution.Hackage.Utils+import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Parse import Distribution.Simple.Configure@@ -15,36 +16,66 @@ import Distribution.Simple.PackageIndex import Distribution.Package import Distribution.Verbosity+import Distribution.Version import System.Directory import System.FilePath  import qualified Data.List as List+import qualified Data.Map as Map -import Codex.Internal+newtype Workspace = Workspace [WorkspaceProject]+  deriving (Eq, Show) +data WorkspaceProject = WorkspaceProject PackageIdentifier FilePath+  deriving (Eq, Show)++type ProjectDependencies = (PackageIdentifier, [PackageIdentifier], [WorkspaceProject])++identifier :: GenericPackageDescription -> PackageIdentifier+identifier = package . packageDescription++allDependencies :: GenericPackageDescription -> [Dependency]+allDependencies pd = List.filter (not . isCurrent) $ concat [lds, eds, tds] where+  lds = condTreeConstraints =<< (maybeToList $ condLibrary pd) +  eds = (condTreeConstraints . snd) =<< condExecutables pd +  tds = (condTreeConstraints . snd) =<< condTestSuites pd +  isCurrent (Dependency n _) = n == (pkgName $ identifier pd)+ findPackageDescription :: FilePath -> IO (Maybe GenericPackageDescription) findPackageDescription root = do   files <- getDirectoryContents root-  traverse (readPackageDescription silent) $ List.find (endswith ".cabal") files+  traverse (readPackageDescription silent) $ fmap (\x -> joinPath [root, x]) $ List.find (endswith ".cabal") files -resolveCurrentProjectDependencies :: IO (PackageIdentifier, [PackageIdentifier])-resolveCurrentProjectDependencies = resolveProjectDependencies "."+resolveCurrentProjectDependencies :: IO ProjectDependencies+resolveCurrentProjectDependencies = do+  ws <- getWorkspace ".."+  resolveProjectDependenciesWithWorkspace ws "." -resolveProjectDependencies :: FilePath -> IO (PackageIdentifier, [PackageIdentifier])-resolveProjectDependencies root = do+-- TODO Optimize+resolveProjectDependenciesWithWorkspace :: Workspace -> FilePath -> IO ProjectDependencies+resolveProjectDependenciesWithWorkspace ws root = do   pd <- maybe (error "No cabal file found.") id <$> findPackageDescription root-  xs <- either (fallback pd) return =<< resolveProjectInstalledDependencies root-  return (identifier pd, xs) where+  xs <- resolveProjectDependencies root pd+  let wsds = List.filter (shouldOverride xs) $ resolveWorkspaceDependencies ws pd+  let pjds = List.filter (\x -> List.notElem (pkgName x) $ fmap (\(WorkspaceProject x _) -> pkgName x) wsds) xs+  return (identifier pd, pjds, wsds) where+    shouldOverride xs (WorkspaceProject x _) = +      maybe True (\y -> pkgVersion x >= pkgVersion y) $ List.find (\y -> pkgName x == pkgName y) xs++resolveProjectDependencies :: FilePath -> GenericPackageDescription -> IO [PackageIdentifier]+resolveProjectDependencies root pd = do+  xs <- either (fallback pd) return =<< resolveInstalledDependencies root+  return xs where     fallback pd e = do       putStrLn $ concat ["cabal: ", show e]       putStrLn "codex: *warning* falling back on dependency resolution using hackage"       resolveWithHackage pd     resolveWithHackage pd = do       db <- readHackage-      return $ identifier <$> resolveDependencies db pd+      return $ identifier <$> resolveHackageDependencies db pd -resolveProjectInstalledDependencies :: FilePath -> IO (Either SomeException [PackageIdentifier])-resolveProjectInstalledDependencies root = try $ do+resolveInstalledDependencies :: FilePath -> IO (Either SomeException [PackageIdentifier])+resolveInstalledDependencies root = try $ do   lbi <- getPersistBuildConfig distPref   let pkg   = localPkgDescr lbi       ipkgs = installedPkgs lbi@@ -53,3 +84,28 @@       xs = fmap sourcePackageId $ (maybeToList . lookupInstalledPackageId ipkgs) =<< fmap fst pkgs   return xs where     distPref = joinPath [root, "dist"]++resolveHackageDependencies :: Hackage -> GenericPackageDescription -> [GenericPackageDescription]+resolveHackageDependencies db pd = maybeToList . resolveDependency db =<< allDependencies pd where+  resolveDependency db (Dependency (PackageName name) versionRange) = do+    pdsByVersion <- Map.lookup name db+    latest <- List.find (\x -> withinRange x versionRange) $ List.reverse $ List.sort $ Map.keys pdsByVersion+    Map.lookup latest pdsByVersion++resolveWorkspaceDependencies :: Workspace -> GenericPackageDescription -> [WorkspaceProject]+resolveWorkspaceDependencies (Workspace ws) pd = maybeToList . resolveDependency =<< allDependencies pd where+  resolveDependency (Dependency name versionRange) = +    List.find (\(WorkspaceProject (PackageIdentifier n v) _) -> n == name && withinRange v versionRange) ws++getWorkspace :: FilePath -> IO Workspace+getWorkspace _root = do+  root <- canonicalizePath _root+  xs <- listDirectory root +  ys <- traverse find xs+  return . Workspace $ ys >>= maybeToList where+    find path = do+      pd <- findPackageDescription path+      return $ fmap (\x -> WorkspaceProject (identifier x) path) pd+    listDirectory fp = do+      xs <- getDirectoryContents fp +      return . fmap (fp </>) $ filter (not . startswith ".") xs

@@ -1,20 +1,9 @@ {-# LANGUAGE CPP #-} module Distribution.Hackage.Utils where -import Data.Maybe-import Distribution.Hackage.DB (Hackage)-import Distribution.Package-import Distribution.PackageDescription-import Distribution.Version import System.Directory import System.FilePath -import qualified Data.List as List-import qualified Data.Map as Map--identifier :: GenericPackageDescription -> PackageIdentifier-identifier = package . packageDescription- -- TODO Remove once path extracted in hackage-db getHackagePath :: IO FilePath getHackagePath = do@@ -26,19 +15,4 @@     ".cabal", "packages" #endif     , "hackage.haskell.org"])--allDependencies :: GenericPackageDescription -> [Dependency]-allDependencies pd = concat [lds, eds, tds] where-  lds = condTreeConstraints =<< (maybeToList $ condLibrary pd) -  eds = (condTreeConstraints . snd) =<< condExecutables pd -  tds = (condTreeConstraints . snd) =<< condTestSuites pd --resolveDependency :: Hackage -> Dependency -> Maybe GenericPackageDescription-resolveDependency db (Dependency (PackageName name) versionRange) = do-  pdsByVersion <- Map.lookup name db-  latest <- List.find (\x -> withinRange x versionRange) $ List.reverse $ List.sort $ Map.keys pdsByVersion-  Map.lookup latest pdsByVersion--resolveDependencies :: Hackage -> GenericPackageDescription -> [GenericPackageDescription]-resolveDependencies db pd = List.filter (\x -> identifier x /= identifier pd) $ maybeToList . resolveDependency db =<< allDependencies pd  

@@ -19,9 +19,8 @@ import System.Exit  import Codex-import Codex.Project (resolveCurrentProjectDependencies)+import Codex.Project --- TODO Implement workspace resolution mechanism -- TODO Add 'cache dump' to dump all tags in stdout (usecase: pipe to grep) -- TODO Use a mergesort algorithm for `assembly` -- TODO Better error handling and fine grained retry@@ -50,26 +49,29 @@  update :: Codex -> Bool -> IO () update cx force = do-    (project, dependencies) <- resolveCurrentProjectDependencies-    shouldUpdate <- either (const True) id <$> (runEitherT $ isUpdateRequired tagsFile dependencies)-    if (shouldUpdate || force) then do-      fileExist <- doesFileExist tagsFile-      when fileExist $ removeFile tagsFile -      putStrLn $ concat ["Updating ", display project]-      results <- traverse (retrying 3 . runEitherT . getTags) dependencies -      traverse (putStrLn . show) . concat $ lefts results-      generate dependencies -    else -      putStrLn "Nothing to update."-    where-      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)-      generate xs = do -        res <- runEitherT $ assembly cx xs tagsFile-        either (putStrLn . show) (const $ return ()) res+  (project, dependencies, workspaceProjects) <- resolveCurrentProjectDependencies++  shouldUpdate <- +    if (null workspaceProjects) then+      either (const True) id <$> (runEitherT $ isUpdateRequired tagsFile dependencies)+    else return True++  if (shouldUpdate || force) then do+    fileExist <- doesFileExist tagsFile+    when fileExist $ removeFile tagsFile +    putStrLn $ concat ["Updating ", display project]+    results <- traverse (retrying 3 . runEitherT . getTags) dependencies +    traverse (putStrLn . show) . concat $ lefts results+    res <- runEitherT $ assembly cx dependencies workspaceProjects tagsFile+    either (putStrLn . show) (const $ return ()) res+  else +    putStrLn "Nothing to update."+  where+    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)  help :: IO () help = putStrLn $