codex 0.0.2.1 → 0.1.0.0

raw patch · 9 files changed

+260/−167 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• codex.cabal +6/−2
• codex/Main.hs +112/−0
• codex/Main/Config.hs +74/−0
• codex/Main/Config/Codex0.hs +12/−0
• src/Codex.hs +8/−5
• src/Codex/Internal.hs +1/−1
• src/Codex/Project.hs +46/−24
• src/Main.hs +0/−134

@@ -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.

@@ -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

@@ -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 <tagger>   Update the `~/.codex` configuration file for the given tagger (hasktags|ctags)."+          , " set format <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)+

@@ -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+

@@ -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+

@@ -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

@@ -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

@@ -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

@@ -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 <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"]