codex 0.0.1.2 → 0.0.1.3

raw patch · 5 files changed

+141/−51 lines, 5 filesdep +eitherdep +textdep +transformersdep −mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: either, text, transformers, yaml

Dependencies removed: mtl

API changes (from Hackage documentation)

Files

• codex.cabal +10/−5
• src/Codex.hs +40/−11
• src/Codex/Internal.hs +1/−1
• src/Distribution/Hackage/Utils.hs +4/−1
• src/Main.hs +86/−33

@@ -1,5 +1,5 @@ name:                codex-version:             0.0.1.2+version:             0.0.1.3 synopsis:            Code Explorer for Cabal description:            This tool download and cache the source code of packages in your local hackage,@@ -20,7 +20,7 @@ library   default-language:  Haskell2010   hs-source-dirs:    src-  ghc-options:       -O2 -threaded -fwarn-incomplete-patterns+  ghc-options:       -fwarn-incomplete-patterns   exposed-modules:     Codex     Codex.Internal@@ -32,24 +32,29 @@     , containers     , directory     , download-curl+    , either     , filepath     , hackage-db-    , mtl+    , MissingH     , process     , tar+    , text+    , transformers     , zlib  executable codex   default-language:  Haskell2010   main-is:           src/Main.hs-  ghc-options:       -O2 -threaded -fwarn-incomplete-patterns+  ghc-options:       -threaded -fwarn-incomplete-patterns   build-depends:              base     , Cabal     , directory+    , either     , filepath     , hackage-db     , MissingH-    , mtl     , monad-loops+    , transformers+    , yaml     , codex 

@@ -2,10 +2,14 @@  import Control.Exception (try, SomeException) import Control.Monad-import Control.Monad.Error-import Data.Traversable (sequenceA)+import Control.Monad.IO.Class+import Control.Monad.Trans.Either+import Data.Hash.MD5+import Data.Traversable (traverse)+import Data.String.Utils import Distribution.Package import Distribution.PackageDescription+import Distribution.Text import Distribution.Verbosity import Network.Curl.Download.Lazy import System.Directory@@ -16,6 +20,9 @@ import qualified Codec.Compression.GZip as GZip import qualified Data.ByteString.Lazy as BS import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TextL+import qualified Data.Text.Lazy.IO as TLIO  import Codex.Internal @@ -31,15 +38,35 @@ data Status = Source Tagging | Archive | Remote   deriving (Eq, Show) -type Action = ErrorT String IO+type Action = EitherT String IO +data Tagger = Ctags | Hasktags+  deriving (Eq, Show, Read)++taggerCmd :: Tagger -> String+taggerCmd Ctags = "ctags --tag-relative=no --recurse -f '$TAGS' '$SOURCES'"+taggerCmd Hasktags = "hasktags --ctags --output='$TAGS' '$SOURCES'"+ -- 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-tryIO io = do +tryIO io = do   res <- liftIO $ (try :: IO a -> IO (Either SomeException a)) io-  either (throwError . show) return res+  either (left . show) return res +dependenciesHash :: [PackageIdentifier] -> String+dependenciesHash xs = md5s . Str $ xs >>= display++isUpdateRequired :: FilePath -> [PackageIdentifier] -> Action Bool+isUpdateRequired file is = do+  fileExist <- tryIO $ doesFileExist file+  if fileExist then do+    content <- tryIO $ TLIO.readFile file+    let hash = TextL.toStrict . TextL.drop 13 . head . drop 2 $ TextL.lines content+    return $ hash /= (Text.pack $ dependenciesHash is)+  else +    return True+ status :: Codex -> PackageIdentifier -> Action Status status cx i = do   sourcesExist <- tryIO . doesDirectoryExist $ packageSources cx i@@ -54,7 +81,7 @@   bs <- tryIO $ do      createDirectoryIfMissing True (packagePath cx i)     openLazyURI url-  either throwError write bs where+  either left write bs where     write bs = fmap (const archivePath) $ tryIO $ BS.writeFile archivePath bs     archivePath = packageArchive cx i     url = packageUrl i@@ -68,16 +95,18 @@ tags cx i = do   tryIO . createProcess $ shell command   return tags where-    command = concat ["ctags --tag-relative=no --recurse -f '", tags, "' '", sources, "'"]     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 <- sequence $ fmap readFile files-    let xs = List.sort . (List.filter (\x -> List.head x /= '!')) . concat $ fmap lines contents-    writeFile o $ unlines (concat [header, xs])+    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-  header = ["!_TAG_FILE_FORMAT 2", "!_TAG_FILE_SORTED 1"]+  headers :: [TextL.Text]+  headers = fmap TextL.pack ["!_TAG_FILE_FORMAT 2", "!_TAG_FILE_SORTED 1", hash]+  hash = concat ["!_CODEX_HASH ", dependenciesHash is] 

@@ -6,7 +6,7 @@ import Distribution.Verbosity import System.FilePath -data Codex = Codex { hackagePath :: FilePath, verbosity :: Verbosity }+data Codex = Codex { tagsCmd :: String, hackagePath :: FilePath }  packagePath :: Codex -> PackageIdentifier -> FilePath packagePath cx i = joinPath [hackagePath cx, relativePath i] where

@@ -12,6 +12,9 @@ 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@@ -37,5 +40,5 @@   Map.lookup latest pdsByVersion  resolveDependencies :: Hackage -> GenericPackageDescription -> [GenericPackageDescription]-resolveDependencies db pd = maybeToList . resolveDependency db =<< allDependencies pd +resolveDependencies db pd = List.filter (\x -> identifier x /= identifier pd) $ maybeToList . resolveDependency db =<< allDependencies pd  

@@ -1,13 +1,19 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-} import Control.Arrow-import Control.Monad.Error-import Data.Traversable (sequenceA)+import Control.Exception (try, SomeException)+import Control.Monad+import Control.Monad.Trans.Either hiding (left, right)+import Data.Either+import Data.Traversable (traverse) import Data.String.Utils+import Data.Yaml import Distribution.Hackage.DB (readHackage)-import Distribution.Package -- TODO Remove import Distribution.PackageDescription import Distribution.PackageDescription.Parse import Distribution.Text import Distribution.Verbosity+import GHC.Generics import System.Directory import System.Environment import System.FilePath@@ -18,10 +24,8 @@  import Codex --- TODO Make Async--- TODO Make verbosity configurable--- TODO Make `ctags` command configurable--- TODO Use `ctags --version` to check if ctags is installed+-- 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@@ -30,36 +34,85 @@     Left ls -> fmap (left (++ ls)) x     Right r -> return $ Right r --- TODO Better error handling and fine grained retry-update :: Codex -> IO ()-update cx = resolve =<< getCurrentProject where-  resolve Nothing = putStrLn "No cabal file found."-  resolve (Just project) = do-    putStrLn $ concat ["Updating ", display . identifier $ project]-    dependencies <- fmap (\db -> resolveDependencies db project) readHackage-    founds <- retrying 4 $ runErrorT . sequence $ fmap (getTags . identifier) dependencies -    failOr (generate dependencies) founds where-      identifier = package . packageDescription-      -- TODO Add println of info (use verbosity)-      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 <- runErrorT $ assembly cx (fmap identifier xs) (joinPath ["codex.tags"])-        failOr (return ()) res-      failOr y x = either (putStrLn . show) (const y) x- getCurrentProject :: IO (Maybe GenericPackageDescription) getCurrentProject = do   files <- getDirectoryContents $ joinPath ["."]-  sequenceA . fmap (readPackageDescription silent) $ List.find (endswith ".cabal") files+  traverse (readPackageDescription silent) $ List.find (endswith ".cabal") files +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 = getCurrentProject >>= resolve where+  resolve Nothing = putStrLn "No cabal file found."+  resolve (Just project) = do+    dependencies <- fmap (\db -> resolveDependencies db project) readHackage+    traverse (putStrLn . show . identifier) dependencies+    shouldUpdate <- runEitherT . isUpdateRequired tagsFile $ fmap identifier dependencies+    when (either (const True) id shouldUpdate || force) $ do+      fileExist <- doesFileExist tagsFile+      when fileExist $ removeFile tagsFile +      putStrLn $ concat ["Updating ", display . identifier $ project]+      results <- traverse (retrying 3 . runEitherT . getTags . identifier) dependencies +      traverse (putStrLn . show) . concat $ lefts results+      generate dependencies 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 (fmap identifier xs) tagsFile+          either (putStrLn . show) (const $ return ()) res+ main :: IO () main = do-  hp    <- getHackagePath+  cx    <- loadConfig   args  <- getArgs-  run (Codex hp silent) args where-    run cx ["update"] = update cx-    run cx _          = putStrLn "Usage: codex update"+  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 _          = putStrLn "Usage: codex [update|cache clean|set tagger [ctags|hasktags]]"++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"]