diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright 2014 Alois Cochard Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/codex.cabal b/codex.cabal --- a/codex.cabal +++ b/codex.cabal @@ -1,5 +1,5 @@ name: codex -version: 0.0.2.1 +version: 0.1.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, @@ -47,8 +47,12 @@ executable codex default-language: Haskell2010 - main-is: src/Main.hs + hs-source-dirs: codex + main-is: Main.hs ghc-options: -threaded -fwarn-incomplete-patterns + other-modules: + Main.Config + Main.Config.Codex0 build-depends: base , Cabal diff --git a/codex/Main.hs b/codex/Main.hs new file mode 100644 --- /dev/null +++ b/codex/Main.hs @@ -0,0 +1,112 @@ +import Control.Arrow +import Control.Exception (try, SomeException) +import Control.Monad +import Control.Monad.Trans.Either hiding (left, right) +import Data.Either +import Data.Functor +import Data.String.Utils +import Data.Traversable (traverse) +import Distribution.Text +import Paths_codex (version) +import System.Directory +import System.Environment +import System.FilePath +import System.Exit + +import Codex +import Codex.Project +import Main.Config + +-- 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 + +retrying :: Int -> IO (Either a b) -> IO (Either [a] b) +retrying n x = retrying' n $ fmap (left (:[])) x where + retrying' 0 x = x + retrying' n x = retrying' (n - 1) $ x >>= \res -> case res of + Left ls -> fmap (left (++ ls)) x + Right r -> return $ Right r + +tagsFile :: FilePath +tagsFile = joinPath ["codex.tags"] + +cleanCache :: Codex -> IO () +cleanCache cx = do + xs <- listDirectory hp + ys <- fmap (rights) $ traverse (safe . listDirectory) xs + zs <- traverse (safe . removeFile) . fmap ( "tags") $ concat ys + return () where + hp = hackagePath cx + safe = (try :: IO a -> IO (Either SomeException a)) + listDirectory fp = do + xs <- getDirectoryContents fp + return . fmap (fp ) $ filter (not . startswith ".") xs + +update :: Codex -> Bool -> IO () +update cx force = do + (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 $ + unlines [ "Usage: codex [update] [cache clean] [set tagger [hasktags|ctags]] [set format [vim|emacs]]" + , " [--help]" + , " [--version]" + , "" + , " update Synchronize the `codex.tags` file in the current cabal project directory" + , " update --force Discard `codex.tags` file hash and force regeneration" + , " cache clean Remove all `tags` file from the local hackage cache]" + , " set tagger Update the `~/.codex` configuration file for the given tagger (hasktags|ctags)." + , " set format Update the `~/.codex` configuration file for the given format (vim|emacs)." + , "" + , "By default `hasktags` will be used, and need to be in the `PATH`, the tagger command can be fully customized in `~/.codex`." + , "" + , "Note: codex will browse the parent directory for cabal projects and use them as dependency over hackage when possible." ] + +main :: IO () +main = do + cx <- loadConfig + 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 ["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 { tagsFileHeader = False, tagsFileSorted = False } + run cx ["set", "format", "vim"] = encodeConfig $ cx { tagsFileHeader = True, tagsFileSorted = True } + run cx ["--version"] = putStrLn $ concat ["codex: ", display version] + run cx ["--help"] = help + run cx [] = help + run cx (x:_) = fail $ concat ["codex: '", x,"' is not a codex command. See 'codex --help'."] + + withConfig cx f = checkConfig cx >>= \state -> case state of + TaggerNotFound -> fail $ "codex: tagger not found." + Ready -> f cx + + fail msg = do + putStrLn $ msg + exitWith (ExitFailure 1) + diff --git a/codex/Main/Config.hs b/codex/Main/Config.hs new file mode 100644 --- /dev/null +++ b/codex/Main/Config.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +module Main.Config where + +import Data.Yaml +import Distribution.Hackage.Utils (getHackagePath) +import GHC.Generics + +import System.Directory +import System.FilePath + +import Codex + +import qualified Main.Config.Codex0 as C0 + +data ConfigState = Ready | TaggerNotFound + +deriving instance Generic Codex +instance ToJSON Codex +instance FromJSON Codex + +getConfigPath :: IO FilePath +getConfigPath = do + homedir <- getHomeDirectory + return $ homedir ".codex" + +checkConfig :: Codex -> IO ConfigState +checkConfig cx = do + taggerExe <- findExecutable tagger + return $ case taggerExe of + Just path -> Ready + _ -> TaggerNotFound + where + tagger = head $ words (tagsCmd cx) + +loadConfig :: IO Codex +loadConfig = decodeConfig >>= maybe defaultConfig return where + defaultConfig = do + hp <- getHackagePath + let cx = Codex hp (taggerCmd Hasktags) True True + encodeConfig cx + return cx + +encodeConfig :: Codex -> IO () +encodeConfig cx = do + path <- getConfigPath + encodeFile path cx + +decodeConfig :: IO (Maybe Codex) +decodeConfig = do + path <- getConfigPath + cfg <- config path + case cfg of + Nothing -> do + cfg0 <- config0 path + case cfg0 of + Nothing -> return Nothing + Just cfg0 -> do + encodeConfig cfg + return $ Just cfg + where + cfg = migrate cfg0 + migrate cx = Codex (C0.hackagePath cx) (C0.tagsCmd cx) True True + cfg -> return cfg + where + config :: FilePath -> IO (Maybe Codex) + config = configOf + config0 :: FilePath -> IO (Maybe C0.Codex) + config0 = configOf + configOf path = do + res <- decodeFileEither path + return $ eitherToMaybe res + eitherToMaybe x = either (const Nothing) Just x + diff --git a/codex/Main/Config/Codex0.hs b/codex/Main/Config/Codex0.hs new file mode 100644 --- /dev/null +++ b/codex/Main/Config/Codex0.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveGeneric #-} +module Main.Config.Codex0 where + +import Data.Yaml +import GHC.Generics + +data Codex = Codex { hackagePath :: FilePath, tagsCmd :: String } + deriving Generic + +instance ToJSON Codex +instance FromJSON Codex + diff --git a/src/Codex.hs b/src/Codex.hs --- a/src/Codex.hs +++ b/src/Codex.hs @@ -118,9 +118,12 @@ tags = 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]) + let xs = concat $ fmap TextL.lines contents + let ys = if sorted then List.sort xs else xs + TLIO.writeFile o $ TextL.unlines (concat [headers, ys]) 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] - + headers = if tagsFileHeader cx then fmap TextL.pack [headerFormat, headerSorted, headerHash] else [] + headerFormat = "!_TAG_FILE_FORMAT 2" + headerSorted = concat ["!_TAG_FILE_SORTED ", if sorted then "1" else "0"] + headerHash = concat ["!_TAG_FILE_CODEX ", dependenciesHash dependencies] + sorted = tagsFileSorted cx diff --git a/src/Codex/Internal.hs b/src/Codex/Internal.hs --- a/src/Codex/Internal.hs +++ b/src/Codex/Internal.hs @@ -6,7 +6,7 @@ import Distribution.Verbosity import System.FilePath -data Codex = Codex { tagsCmd :: String, hackagePath :: FilePath } +data Codex = Codex { hackagePath :: FilePath, tagsCmd :: String, tagsFileHeader :: Bool, tagsFileSorted :: Bool } packagePath :: Codex -> PackageIdentifier -> FilePath packagePath cx i = hackagePath cx relativePath i where diff --git a/src/Codex/Project.hs b/src/Codex/Project.hs --- a/src/Codex/Project.hs +++ b/src/Codex/Project.hs @@ -2,6 +2,7 @@ import Control.Exception (try, SomeException) import Data.Functor +import Data.Function import Data.Maybe import Data.String.Utils import Data.Traversable (traverse) @@ -26,7 +27,7 @@ newtype Workspace = Workspace [WorkspaceProject] deriving (Eq, Show) -data WorkspaceProject = WorkspaceProject PackageIdentifier FilePath +data WorkspaceProject = WorkspaceProject { workspaceProjectIdentifier :: PackageIdentifier, workspaceProjectPath :: FilePath } deriving (Eq, Show) type ProjectDependencies = (PackageIdentifier, [PackageIdentifier], [WorkspaceProject]) @@ -49,30 +50,21 @@ resolveCurrentProjectDependencies :: IO ProjectDependencies resolveCurrentProjectDependencies = do ws <- getWorkspace ".." - resolveProjectDependenciesWithWorkspace ws "." + resolveProjectDependencies ws "." -- TODO Optimize -resolveProjectDependenciesWithWorkspace :: Workspace -> FilePath -> IO ProjectDependencies -resolveProjectDependenciesWithWorkspace ws root = do +resolveProjectDependencies :: Workspace -> FilePath -> IO ProjectDependencies +resolveProjectDependencies ws root = do pd <- maybe (error "No cabal file found.") id <$> findPackageDescription root - 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 + xs <- resolvePackageDependencies root pd + ys <- resolveSandboxDependencies root + let zs = resolveWorkspaceDependencies ws pd + let wsds = List.filter (shouldOverride xs) $ List.nubBy (on (==) prjId) $ concat [ys, zs] + let pjds = List.filter (\x -> List.notElem (pkgName x) $ fmap prjId 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 <$> resolveHackageDependencies db pd + prjId = pkgName . workspaceProjectIdentifier resolveInstalledDependencies :: FilePath -> IO (Either SomeException [PackageIdentifier]) resolveInstalledDependencies root = try $ do @@ -81,7 +73,8 @@ ipkgs = installedPkgs lbi clbis = snd <$> allComponentsInBuildOrder lbi pkgs = componentPackageDeps =<< clbis - xs = fmap sourcePackageId $ (maybeToList . lookupInstalledPackageId ipkgs) =<< fmap fst pkgs + ys = (maybeToList . lookupInstalledPackageId ipkgs) =<< fmap fst pkgs + xs = fmap sourcePackageId $ ys return xs where distPref = root "dist" @@ -92,11 +85,43 @@ latest <- List.find (\x -> withinRange x versionRange) $ List.reverse $ List.sort $ Map.keys pdsByVersion Map.lookup latest pdsByVersion +resolvePackageDependencies :: FilePath -> GenericPackageDescription -> IO [PackageIdentifier] +resolvePackageDependencies 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 <$> resolveHackageDependencies db pd + +resolveSandboxDependencies :: FilePath -> IO [WorkspaceProject] +resolveSandboxDependencies root = do + fileExists <- doesFileExist sourcesFile + if fileExists then readSources else return [] where + 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) + 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 resolveDependency (Dependency name versionRange) = List.find (\(WorkspaceProject (PackageIdentifier n v) _) -> n == name && withinRange v versionRange) ws +readWorkspaceProject :: FilePath -> IO (Maybe WorkspaceProject) +readWorkspaceProject path = do + pd <- findPackageDescription path + return $ fmap (\x -> WorkspaceProject (identifier x) path) pd + getWorkspace :: FilePath -> IO Workspace getWorkspace _root = do root <- canonicalizePath _root @@ -105,10 +130,7 @@ return . Workspace $ ys >>= maybeToList where find path = do isDirectory <- doesDirectoryExist path - if isDirectory then do - pd <- findPackageDescription path - return $ fmap (\x -> WorkspaceProject (identifier x) path) pd - else return Nothing + if isDirectory then readWorkspaceProject path else return Nothing listDirectory fp = do xs <- getDirectoryContents fp return . fmap (fp ) $ filter (not . startswith ".") xs diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -import Control.Arrow -import Control.Exception (try, SomeException) -import Control.Monad -import Control.Monad.Trans.Either hiding (left, right) -import Data.Either -import Data.Functor -import Data.String.Utils -import Data.Traversable (traverse) -import Data.Yaml -import Distribution.Hackage.Utils (getHackagePath) -import Distribution.Text -import GHC.Generics -import Paths_codex (version) -import System.Directory -import System.Environment -import System.FilePath -import System.Exit - -import Codex -import Codex.Project - --- 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 - -retrying :: Int -> IO (Either a b) -> IO (Either [a] b) -retrying n x = retrying' n $ fmap (left (:[])) x where - retrying' 0 x = x - retrying' n x = retrying' (n - 1) $ x >>= \res -> case res of - Left ls -> fmap (left (++ ls)) x - Right r -> return $ Right r - -tagsFile :: FilePath -tagsFile = joinPath ["codex.tags"] - -cleanCache :: Codex -> IO () -cleanCache cx = do - xs <- listDirectory hp - ys <- fmap (rights) $ traverse (safe . listDirectory) xs - zs <- traverse (safe . removeFile) . fmap ( "tags") $ concat ys - return () where - hp = hackagePath cx - safe = (try :: IO a -> IO (Either SomeException a)) - listDirectory fp = do - xs <- getDirectoryContents fp - return . fmap (fp ) $ filter (not . startswith ".") xs - -update :: Codex -> Bool -> IO () -update cx force = do - (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 $ - unlines [ "Usage: codex [update] [cache clean] [set tagger [hasktags|ctags]]" - , " [--help]" - , " [--version]" - , "" - , " update Synchronize the `codex.tags` file in the current cabal project directory" - , " update --force Discard `codex.tags` file hash and force regeneration" - , " cache clean Remove all `tags` file from the local hackage cache]" - , " set tagger Update the `~/.codex` configuration file for the given tagger (hasktags|ctags)." - , "" - , "By default `hasktags` will be used, and need to be in the `PATH`, the tagger command can be fully customized in `~/.codex`." - , "" - , "Note: codex will browse the parent directory for cabal projects and use them as dependency over hackage when possible." ] - -main :: IO () -main = do - cx <- loadConfig - args <- getArgs - run cx args where - run cx ["cache", clean] = cleanCache cx - run cx ["update"] = update cx False - run cx ["update", "--force"] = update cx True - run cx ["set", "tagger", "ctags"] = encodeConfig $ cx { tagsCmd = taggerCmd Ctags } - run cx ["set", "tagger", "hasktags"] = encodeConfig $ cx { tagsCmd = taggerCmd Hasktags } - run cx ["--version"] = putStrLn $ concat ["codex: ", display version] - run cx ["--help"] = help - run cx [] = help - run cx (x:_) = do - putStrLn $ concat ["codex: '", x,"' is not a codex command. See 'codex --help'."] - exitWith (ExitFailure 1) - -loadConfig :: IO Codex -loadConfig = decodeConfig >>= maybe defaultConfig return where - defaultConfig = do - hp <- getHackagePath - let cx = Codex (taggerCmd Hasktags) hp - encodeConfig cx - return cx - -deriving instance Generic Codex -instance ToJSON Codex -instance FromJSON Codex - -encodeConfig :: Codex -> IO () -encodeConfig cx = do - path <- getConfigPath - encodeFile path cx - -decodeConfig :: IO (Maybe Codex) -decodeConfig = do - path <- getConfigPath - res <- decodeFileEither path - return $ either (const Nothing) Just res - -getConfigPath :: IO FilePath -getConfigPath = do - homedir <- getHomeDirectory - return $ joinPath [homedir, ".codex"]