stack-tag (empty) → 0.2.0
raw patch · 7 files changed
+472/−0 lines, 7 filesdep +asyncdep +basedep +containerssetup-changed
Dependencies added: async, base, containers, directory, hasktags, mtl, optparse-applicative, process, stack-tag, text
Files
- LICENSE +20/−0
- README.md +24/−0
- Setup.hs +2/−0
- app/Main.hs +44/−0
- src/Control/Concurrent/Async/Pool.hs +50/−0
- src/Stack/Tag.hs +270/−0
- stack-tag.cabal +62/−0
+ LICENSE view
@@ -0,0 +1,20 @@+MIT License++Copyright (c) 2018 <creichert07@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is furnished+to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS+OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF+OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,24 @@++# Stack Tag++Create etags & ctags for Haskell projects based on Stack snapshots.++## Quick start++ stack install stack-tag+ stack-tag && cp stack.tag TAGS++When you change a source file, run:++ stack-tag && cp stack.tag TAGS++## Features++- Tag files are based on snapshots. All generated tags will correspond to+ the exact matching version found in the active stack `resolver`.++- Tag files are cached. Dependencies only need to be downloaded once per+ snapshot.++- Transitive dependencies are tagged, including dependencies in+ `executable`, `test-suite` and `benchmark` stanzas.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,44 @@++-- | `stack-tag' executable main module++module Main where++import Control.Applicative+import Data.Monoid+import Options.Applicative+import Stack.Tag++stackTagOptions :: Parser StackTagOpts+stackTagOptions =+ StackTagOpts+ <$> optional+ ( strOption+ ( long "stack-yaml"+ <> metavar "STACK_YAML"+ <> help "Location of stack.yaml" ) )+ <*> switch+ ( long "verbose"+ <> help "Verbose debug output" )+ <*> switch+ ( long "no-cache"+ <> help "Completely re-run tag command. Don't use cached tag files." )++optsDesc :: String+optsDesc = "Create ctags/etags for a project and all dependencies"++optsHeader :: String+optsHeader = "stack-tag - Create etags/ctags for a stack project based on snapshot"++stackTagOpts :: ParserInfo StackTagOpts+stackTagOpts =+ info+ (helper+ <*> infoOption "stack-tag v0.2.0, (c) Christopher Reichert 2018"+ ( long "version" <> help "Display version string" )+ <*> stackTagOptions )+ ( fullDesc+ <> progDesc optsDesc+ <> header optsHeader )++main :: IO ()+main = execParser stackTagOpts >>= stackTag
+ src/Control/Concurrent/Async/Pool.hs view
@@ -0,0 +1,50 @@++-- | Simple implementation for limiting the number+-- of active threads during concurrent computations+-- using a semaphore.++{-# LANGUAGE CPP #-}++module Control.Concurrent.Async.Pool+ (+ mapPool+ , mapCapabilityPool+ ) where++import qualified Control.Exception as E+import Control.Concurrent+import Control.Concurrent.Async++#if !MIN_VERSION_base(4,8,0)+import Data.Traversable (Traversable)+#endif++-- ifdef GHC+-- import GHC.Conc (getNumProcessors)+-- endif+++-- | Map async using 'getNumCapabilities' to determine+-- the number of active threads.+--+-- This function is a bit misleading as it doesn't actually utilize+-- 'forkOn' or exploit any control over whether the threads are+-- spread across physical processors. It does, however, provide a+-- nice starting point for most of the threads used in this program+-- which are heavily IO bound.+mapCapabilityPool :: Traversable t => (a -> IO b) -> t a -> IO (t b)+mapCapabilityPool f xs = do+ -- num <- getNumProcessors+ num <- getNumCapabilities+ mapPool (num+1) f xs++-- | Limit the number of threads which can be active at any+-- given time when using 'mapConcurrently'. The downside is+-- that this function will allocate all threads at once.+mapPool :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b)+mapPool num f xs = do+ sem <- newQSem num+ mapConcurrently (withQSem sem . f) xs++withQSem :: QSem -> IO a -> IO a+withQSem m = E.bracket_ (waitQSem m) (signalQSem m)
+ src/Stack/Tag.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | TAG a stack project based on snapshot versions++module Stack.Tag where++import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Traversable as T++import Control.Exception as E+import Control.Monad.Reader+import Data.Either+import Data.Maybe+import Data.Text (Text)+import System.Directory+import System.Exit+import System.Process++import Control.Concurrent.Async.Pool+++data StackTagOpts = StackTagOpts {++ -- | Location of the stack.yaml to generate tags for+ optsStackYaml :: !(Maybe FilePath)++ -- | Verbose output+ , optsVerbose :: !Bool++ -- | Flag to ignore any cached tags and re-run the tagger+ , noCache :: !Bool++ } deriving Show+++data Tagger = Hasktags+ | HotHasktags+ | OtherTagger Text+ deriving Show++data TagFmt = CTags+ | ETags+ | Both+ | OtherFmt Text+ deriving Show++type TagOutput = FilePath+type SourceDir = FilePath+type PkgName = String++data TagCmd = TagCmd Tagger TagFmt TagOutput SourceDir PkgName deriving Show++newtype StackTag a = StackTag {+ runStackTag :: ReaderT StackTagOpts IO a+ } deriving (+ Functor+ , Applicative+ , Monad+ , MonadReader StackTagOpts+ , MonadIO+ )++defStackOpts :: StackTagOpts+defStackOpts = StackTagOpts Nothing False True++stackTag :: StackTagOpts -> IO ()+stackTag = runReaderT (runStackTag app)+ where+ app = do chkStackCompatible+ chkHaskTags+ chkIsStack+ sources <- stkPaths+ depSources <- stkDepSources+ tagSources sources depSources++--------------------------------------------------------------------------+--------------------------------------------------------------------------++io :: MonadIO m => IO a -> m a+io = liftIO++p :: String -> StackTag ()+p msg = whenM (ask >>= pure . optsVerbose) $ io (putStrLn msg)++whenM :: Monad m => m Bool -> m () -> m ()+whenM predicate go = predicate >>= flip when go++-- | Run a command using the `stack' command-line tool+-- with a list of arguments+runStk :: [String] -> StackTag (ExitCode, String, String)+runStk args = io $ readProcessWithExitCode "stack" args []++chkIsStack :: StackTag ()+chkIsStack = do+ StackTagOpts {optsStackYaml=stackYaml} <- ask+ sYaml <- io $ doesFileExist "stack.yaml"++ case stackYaml of+ Nothing -> unless sYaml $ error "stack.yaml not found or specified!"+ _ -> return ()++chkHaskTags :: StackTag ()+chkHaskTags = do+ ht <- io $ findExecutable "hasktags"+ case ht of+ Just _p -> return ()+ Nothing -> error "You must have hasktags installed Run 'stack install hasktags'."++--- | Check whether the current version of stack+-- is compatible by trying to run `stack list-depenencies --help`.+chkStackCompatible :: StackTag ()+chkStackCompatible = do+ (exitc, _, _) <- runStk ["ls", "dependencies", "--help"]+ case exitc of+ ExitSuccess -> return ()+ ExitFailure _e ->+ p (show exitc) >> error "You need stack version 1.7.1 or higher installed and in your PATH to use stack-tag"++-- | Get a list of relavant directories from stack using+-- the @stack path@ command+stkPaths :: StackTag [(Text,[Text])]+stkPaths = do+ (_,ps,_) <- runStk ["path"]+ return (parsePaths ps)+ where+ parsePaths = map parsePath . T.lines . T.pack+ parsePath ps = let (k,vs) = T.breakOn ":" ps+ in (k, splitAndStrip vs)+ splitAndStrip = filter (not . T.null) . map T.strip . T.splitOn ":"++-- | Get a list of dependencies using:+-- @stack --list-dependencies --test --bench --separator=-@+stkDepSources :: StackTag [String]+stkDepSources = do+ (_exitc,ls,_) <- runStk [ "ls", "dependencies", "--external"+ , "--include-base", "--test"+ , "--bench", "--separator=-"]+ return $ lines ls++--------------------------------------------------------------------------+--------------------------------------------------------------------------++tagSources :: [(Text,[Text])] -> [FilePath] -> StackTag ()+tagSources srcs depsrcs = do++ let srcDir = lookup "project-root" srcs+ let tagroot = T.unpack . fromMaybe "." . listToMaybe . fromMaybe [] $ srcDir++ -- alternative pooled+ depTagFiles <- parTag srcs depsrcs++ -- map a tag command over all provided sources+ thisProj <- runTagger (TagCmd Hasktags ETags "stack.tags" tagroot "project-root")+ taggedSrcs <- T.traverse (io . readFile) (rights (thisProj : depTagFiles))++ let errors = lefts (thisProj : depTagFiles)+ unless (null errors) $ do++ let pkg_errs = map (\(pkg,err) -> pkg ++ ": " ++ err) $ take 10 errors+ error $ unlines $+ "[tag:error] stack-tag encountered errors creating tags"+ : pkg_errs++ let xs = concatMap lines taggedSrcs+ ys = if False then (Set.toList . Set.fromList) xs else xs++ p $ "[tag:done] built & merged tags for " ++ show (length taggedSrcs) ++ " projects"+ io $ writeFile "TAGS" $ unlines ys++parTag :: [(Text, [Text])] -> [FilePath] -> StackTag [Either (PkgName, String) FilePath]+parTag srcs depsrcs = do++ o@StackTagOpts {noCache=nocache} <- ask++ -- control the number of jobs by using capabilities Currently,+ -- capabilities creates a few too many threads which saturates the+ -- CPU and network connection. For now, it's manually set to 3 until+ -- a better threading story is figured out.+ --+ -- io $ mapCapabilityPool (tagDependency nocache srcs) depsrcs++ -- WAT: rewrap the transformer. It's less heavy duty than bringing in+ -- monad-control or refactoring (2018-09-14)+ let worker osrc = flip runReaderT o $ do+ runStackTag (tagDependency nocache srcs osrc)++ io $ mapPool 3 worker depsrcs++-- | Tag a single dependency+tagDependency :: Bool -> [(Text, [Text])] -> FilePath -> StackTag (Either (PkgName, String) FilePath)+tagDependency nocache stkpaths dep = do++ let snapRoot+ | Just (sr : _) <- lookup "snapshot-install-root" stkpaths = sr+ | otherwise = error ("[tag:error] error tagging "+ ++ dep+ ++ ". "+ ++ "No 'snapshot-install-root' found, aborting.")+ dir = T.unpack snapRoot ++ "/packages" ++ "/" ++ dep+ tagFile = dir ++ "/TAGS"++ -- HACK as of Aug 5 2015, `stack unpack` can only download sources+ -- into the current directory. Therefore, we move the source to+ -- the correct snapshot location. This could/should be fixed in+ -- the stack source (especially since --haddock has similar+ -- behavior). A quick solution to avoid this might be to run the+ -- entire function in the target directory+ _ <- io $ readProcess "rm" ["--preserve-root", "-rf", dep] []++ -- error (show dep)++ exists <- io $ doesDirectoryExist dir+ tagged <- io $ doesFileExist tagFile++ unless exists $ void $ do+ io $ createDirectoryIfMissing True dir+ p $ "[tag:download] " ++ dep+ (ec,stout,_) <- runStk ["unpack", dep]+ case ec of+ ExitFailure _ -> void $ do+ p $ "[tag:download] failed to download " ++ dep ++ " - " ++ stout+ ExitSuccess -> void $ do+ p $ "[tag:download] cp " ++ dep ++ " to snapshot source cache in " ++ dir+ io $ readProcess "mv" [dep,dir] []++ if tagged && nocache+ then do p $ "[tag:nocache] " ++ dep+ return (Right tagFile)+ else do p $ "[tag:cache] " ++ dep+ runTagger (TagCmd Hasktags ETags tagFile dir dep)++runTagger :: TagCmd -> StackTag (Either (PkgName, String) TagOutput)+runTagger (TagCmd t fmt to fp dep) = do++ let opts = [ tagFmt fmt+ , "-R" -- tags-absolute+ -- made the default & removed+ -- , "--ignore-close-implementation"+ , "--follow-symlinks"+ -- , "--cache"+ , "--output"+ , to+ , fp+ ]++ (ec, stout, err) <- hasktags opts++ case ec of+ ExitFailure _+ | null err -> return $ Left (dep, stout)+ | otherwise -> return $ Left (dep, err)+ ExitSuccess -> return $ Right to+ where+ hasktags opts = io $+ readProcessWithExitCode (tagExe t) opts []+ `E.catch` (\(SomeException err) -> return (ExitFailure 1, displayException err, ""))+++-- TODO tagExe Hasktags = "fast-tags"+tagExe :: Tagger -> String+tagExe Hasktags = "hasktags"+tagExe _ = error "Tag command not supported. Feel free to create an issue at https://github.com/creichert/stack-tag"++tagFmt :: TagFmt -> String+tagFmt ETags = "--etags"+tagFmt CTags = "--etags"+tagFmt Both = "--both"+tagFmt _ = error "Tag format not supported. Feel free to create an issue at https://github.com/creichert/stack-tag"
+ stack-tag.cabal view
@@ -0,0 +1,62 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: afbd96c44b36d740c83eee5446c82c42926b224aed87726ed37b693caa028b7c++name: stack-tag+version: 0.2.0+synopsis: Create etags for Haskell projects based on Stack snapshots+homepage: https://github.com/creichert/stack-tag#readme+bug-reports: https://github.com/creichert/stack-tag/issues+author: Christopher & Cody Reichert (Reichert Brothers)+maintainer: christopher@reichertbrothers.com+copyright: 2018 Reichert Brothers+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/creichert/stack-tag++library+ exposed-modules:+ Control.Concurrent.Async.Pool+ Stack.Tag+ other-modules:+ Paths_stack_tag+ hs-source-dirs:+ src+ ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ build-depends:+ async+ , base >=4.7 && <5+ , containers+ , directory+ , hasktags+ , mtl+ , process+ , text+ default-language: Haskell2010++executable stack-tag+ main-is: app/Main.hs+ other-modules:+ Paths_stack_tag+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ build-depends:+ async+ , base >=4.7 && <5+ , containers+ , directory+ , hasktags+ , mtl+ , optparse-applicative+ , process+ , stack-tag+ , text+ default-language: Haskell2010