diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -46,8 +46,9 @@ haskdogs - Recursive hasktags-based TAGS generator for a Haskell project Usage: haskdogs [--version] [-d|--dir-list FILE] [-f|--file-list FILE] - [--hasktags-args OPTS] [--stack-args OPTS] [--ghc-pkg-args OPTS] - [--use-stack ARG] [--deps-dir PATH] [--raw] [OPTS] + [-i|--input FILE] [--hasktags-args OPTS] [--stack-args OPTS] + [--ghc-pkg-args OPTS] [--use-stack ARG] [--deps-dir PATH] + [--raw] [-q|--quiet] [OPTS] Available options: -h,--help Show this help text @@ -56,6 +57,8 @@ read from stdin) -f,--file-list FILE File containing Haskell sources to process (use '-' to read from stdin) + -i,--input FILE Single Haskell file to process (use '-' to read + Haskell source from stdin) --hasktags-args OPTS Arguments to pass to hasktags. -c -x is the default. Not for raw mode. --stack-args OPTS Arguments to pass to stack @@ -63,14 +66,14 @@ --use-stack ARG Execute ghc-pkg via stack, arg is ON, OFF or AUTO (the default) --deps-dir PATH Specify the directory PATH to place the dependencies - of the project. Default is [/home/grwlf/.haskdogs] + of the project. Default is [$HOME/.haskdogs] --raw Don't execute hasktags, print list of files to tag on the STDOUT. The output may be piped into hasktags like this: `haskdogs --raw | hasktags -c -x STDIN' + -q,--quiet Don't print verbose messages OPTS More hasktags options, use `--' to pass flags starting with `-'. Not for raw mode. - The following error could be caused by (over)strict Haskell policy regarding Unicode locale: @@ -130,4 +133,15 @@ nix-shell -p haskellPackages.haskdogs haskellPackages.hasktags haskellPackages.cabal-install ghc (nix-shell) $ haskdogs + +TIPS +----- + +* create tags for specific package + + ``echo 'import Control.Lens' | haskdogs -i -`` + +* incremental update + + ``haskdogs -i % --hasktags-args "-x -c -a" | sort -u -o tags tags`` diff --git a/haskdogs.cabal b/haskdogs.cabal --- a/haskdogs.cabal +++ b/haskdogs.cabal @@ -1,5 +1,5 @@ Name: haskdogs -Version: 0.5.4 +Version: 0.6.0 Synopsis: Generate tags file for Haskell project and its nearest deps Homepage: http://github.com/grwlf/haskdogs License: BSD3 @@ -35,11 +35,10 @@ Main-is: Main.hs Build-depends: base >= 4.8 && < 5 , filepath - , bytestring , text , directory , optparse-applicative - , process + , process-extras , containers , hasktags diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,22 +1,28 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main (main) where -import Control.Monad import Control.Applicative import Control.Exception -import Data.Maybe +import Control.Monad import Data.List -import System.IO +import Data.Maybe import System.Directory -import System.Process (readProcess) import System.FilePath - -import Data.Monoid((<>)) +import System.IO +import System.Exit (ExitCode(..)) +import System.Process.Text (readProcessWithExitCode) +import Data.Monoid ((<>)) import Data.Set (Set) -import qualified Data.Set as Set -import Options.Applicative -import qualified Options.Applicative as O +import Data.Text (Text, unpack, pack) import Data.Version (showVersion) +import Options.Applicative + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Set as Set import qualified Paths_haskdogs as Paths {- @@ -29,22 +35,23 @@ -} data Opts = Opts { - cli_dirlist_file :: FilePath - , cli_filelist_file :: FilePath + cli_dirlist_file :: FilePath + , cli_filelist_file :: FilePath + , cli_input_file :: FilePath , cli_hasktags_args1 :: String - , cli_stack_args :: String - , cli_ghc_pkgs_args :: String - , cli_use_stack :: Tristate - , cli_deps_dir :: FilePath - , cli_raw_mode :: Bool - -- , cli_use_sandbox :: Tristate + , cli_stack_args :: String + , cli_ghc_pkgs_args :: String + , cli_use_stack :: Tristate + , cli_deps_dir :: FilePath + , cli_raw_mode :: Bool + , cli_verbose :: Bool , cli_hasktags_args2 :: [String] } deriving(Show) data Tristate = ON | OFF | AUTO deriving(Eq, Ord, Show, Read) -def_hasktags_args = words "-c -x" +defHasktagsArgs = words "-c -x" optsParser :: FilePath -> Parser Opts optsParser def_deps_dir = Opts @@ -61,15 +68,21 @@ value "" <> help "File containing Haskell sources to process (use '-' to read from stdin)" ) <*> strOption ( + long "input" <> + short 'i' <> + metavar "FILE" <> + value "" <> + help "Single Haskell file to process (use '-' to read Haskell source from stdin)" ) + <*> strOption ( long "hasktags-args" <> metavar "OPTS" <> value "" <> - help ("Arguments to pass to hasktags. " ++ unwords def_hasktags_args ++ " is the default. Not for raw mode.")) + help ("Arguments to pass to hasktags. " <> unwords defHasktagsArgs <> " is the default. Not for raw mode.")) <*> strOption ( long "stack-args" <> metavar "OPTS" <> value "" <> - help ("Arguments to pass to stack")) + help "Arguments to pass to stack") <*> strOption ( long "ghc-pkg-args" <> metavar "OPTS" <> @@ -87,21 +100,21 @@ <*> flag False True ( long "raw" <> help "Don't execute hasktags, print list of files to tag on the STDOUT. The output may be piped into hasktags like this: `haskdogs --raw | hasktags -c -x STDIN'") - -- <*> option auto ( - -- long "include-sandbox" <> - -- value AUTO <> - -- help "(!UNIMPLEMENTED!) Include .cabal-sandbox package databases") + <*> flag True False ( + long "quiet" <> + short 'q' <> + help "Don't print verbose messages") <*> many (argument str (metavar "OPTS" <> help "More hasktags options, use `--' to pass flags starting with `-'. Not for raw mode.")) exename :: String exename = "haskdogs" versionParser :: Parser (a -> a) -versionParser = infoOption (exename ++ " version " ++ (showVersion Paths.version)) +versionParser = infoOption (exename <> " version " <> showVersion Paths.version) (long "version" <> help "Show version number") -opts def_deps_dir = info (helper <*> versionParser <*> (optsParser def_deps_dir)) - ( fullDesc <> header (exename ++ " - Recursive hasktags-based TAGS generator for a Haskell project" )) +opts def_deps_dir = info (helper <*> versionParser <*> optsParser def_deps_dir) + ( fullDesc <> header (exename <> " - Recursive hasktags-based TAGS generator for a Haskell project" )) {- __ __ _ @@ -120,7 +133,7 @@ Opts {..} <- execParser (opts def_deps_dir) let - cli_hasktags_args = (words cli_hasktags_args1) ++ cli_hasktags_args2 + cli_hasktags_args = words cli_hasktags_args1 <> cli_hasktags_args2 -- Directory to unpack sources into getDataDir :: IO FilePath @@ -128,8 +141,6 @@ createDirectoryIfMissing False cli_deps_dir return cli_deps_dir - cli_verbose = True - vprint a | cli_verbose = eprint a | otherwise = return () @@ -137,23 +148,26 @@ eprint = hPutStrLn stderr runp nm args inp = do - vprint $ "> " ++ nm ++ " " ++ unwords args - readProcess nm args inp + vprint $ "> " <> nm <> " " <> unwords args + (ec, out, err) <- readProcessWithExitCode nm args inp + case ec of + ExitSuccess -> return out + ec -> ioError (userError $ nm <> " " <> show args <> " exited with error code " <> show ec <> " and output:\n" <> init (unpack err)) -- Run GNU which tool checkapp :: String -> IO () - checkapp appname = do - (runp "which" [appname] [] >> return ()) `onException` - (eprint ("Please Install \"" ++ appname ++ "\" application")) + checkapp appname = + void (runp "which" [appname] "") `onException` + eprint ("Please Install \"" <> appname <> "\" application") hasapp :: String -> IO Bool hasapp appname = do - vprint $ "Cheking for " ++ appname ++ " with GNU which" - (runp "which" [appname] [] >> return True) `catch` - (\(e::SomeException) -> vprint ("GNU which falied to find " ++ appname) >> return False) + vprint $ "Cheking for " <> appname <> " with GNU which" + (runp "which" [appname] "" >> return True) `catch` + (\(e::SomeException) -> vprint ("GNU which falied to find " <> appname) >> return False) - when ((not $ null cli_hasktags_args) && cli_raw_mode) $ do - fail $ "--raw is incompatible with passing hasktags arguments" + when (not (null cli_hasktags_args) && cli_raw_mode) $ + fail "--raw is incompatible with passing hasktags arguments" cwd <- getCurrentDirectory datadir <- getDataDir @@ -162,26 +176,30 @@ let + readLinedFile :: FilePath -> IO [Text] readLinedFile f = - lines <$> (hGetContents =<< ( - if (f=="-") + Text.lines <$> (Text.hGetContents =<< ( + if f=="-" then return stdin else openFile f ReadMode)) readDirFile :: IO [FilePath] readDirFile - | null cli_dirlist_file && null cli_filelist_file = return ["."] + | null cli_dirlist_file && null cli_filelist_file && null cli_input_file = return ["."] | null cli_dirlist_file = return [] - | otherwise = readLinedFile cli_dirlist_file + | otherwise = map unpack <$> readLinedFile cli_dirlist_file - readSourceFile :: IO (Set FilePath) - readSourceFile - | null cli_filelist_file = return Set.empty - | otherwise = Set.fromList <$> readLinedFile cli_filelist_file + readSourceFile :: IO (Set Text) + readSourceFile = do + files1 <- if | null cli_filelist_file -> return Set.empty + | otherwise -> Set.fromList <$> readLinedFile cli_filelist_file + files2 <- if | null cli_input_file -> return Set.empty + | otherwise -> return $ Set.singleton (pack cli_input_file) + return $ files1 <> files2 runp_ghc_pkgs args = go cli_use_stack where - go ON = runp "stack" (["exec", "ghc-pkg"] ++ (words cli_stack_args) ++ ["--"] ++ (words cli_ghc_pkgs_args) ++ args) [] - go OFF = runp "ghc-pkg" (words cli_ghc_pkgs_args ++ args) [] + go ON = runp "stack" (["exec", "ghc-pkg"] <> words cli_stack_args <> ["--"] <> words cli_ghc_pkgs_args <> args) "" + go OFF = runp "ghc-pkg" (words cli_ghc_pkgs_args <> args) "" go AUTO = case (has_stack,has_cabal) of (True,_) -> go ON @@ -198,73 +216,75 @@ (False,False) -> fail "Either `stack` or `cabal` should be installed" -- Finds *hs in dirs, but filter-out Setup.hs - findSources :: [FilePath] -> IO (Set FilePath) + findSources :: [FilePath] -> IO (Set Text) findSources [] = return Set.empty findSources dirs = - Set.fromList . filter (not . isSuffixOf "Setup.hs") . lines <$> - runp "find" (dirs ++ words "-type f -and ( -name *\\.hs -or -name *\\.lhs -or -name *\\.hsc )") [] + Set.fromList . filter (not . Text.isSuffixOf "Setup.hs") . Text.lines <$> + runp "find" (dirs <> words "-type f -and ( -name *\\.hs -or -name *\\.lhs -or -name *\\.hsc )") "" - grepImports :: String -> Maybe String - grepImports line = case words line of - ("import":"qualified":x:_) -> Just (filter (/=';') x) - ("import":x:_) -> Just (filter (/=';') x) + grepImports :: Text -> Maybe Text + grepImports line = + case Text.words line of + ("import":"qualified":x:_) -> Just (Text.filter (/=';') x) + ("import":x:_) -> Just (Text.filter (/=';') x) _ -> Nothing - -- Produces list of imported modules for file.hs given - findModules :: Set FilePath -> IO [String] - findModules files = (catMaybes . map grepImports . lines) <$> runp "cat" (Set.toList files) [] + -- Scan input files, produces list of imported modules + findModules :: Set Text -> IO [Text] + findModules files = + fmap concat . mapM (fmap (mapMaybe grepImports) . readLinedFile . unpack) $ Set.toList files -- Maps import name to haskell package name - iname2module :: String -> IO (Maybe String) + iname2module :: Text -> IO (Maybe Text) iname2module iname = do - mod <- (listToMaybe . words) <$> (runp_ghc_pkgs ["--simple-output", "find-module", iname]) - vprint $ "Import " ++ iname ++ " resolved to " ++ (fromMaybe "NULL" mod) - return mod + mod <- listToMaybe . Text.words <$> runp_ghc_pkgs ["--simple-output", "find-module", unpack iname] + vprint $ "Import " <> unpack iname <> " resolved to " <> maybe "NULL" unpack mod + return mod - inames2modules :: [String] -> IO [FilePath] - inames2modules is = nub . sort . catMaybes <$> forM (nub is) iname2module + inames2modules :: [Text] -> IO [FilePath] + inames2modules inames = map unpack . nub . sort . catMaybes <$> mapM iname2module (nub inames) -- Unapcks haskel package to the sourcedir unpackModule :: FilePath -> IO (Maybe FilePath) unpackModule mod = do let p = datadirmod exists <- doesDirectoryExist p - case exists of - True -> do - vprint $ "Already unpacked " ++ mod + if exists + then do + vprint $ "Already unpacked " <> mod return (Just p) - False -> do + else bracket_ (setCurrentDirectory datadir) (setCurrentDirectory cwd) $ - ( runp cabal_or_stack ["unpack", mod] [] >> return (Just p) + ( runp cabal_or_stack ["unpack", mod] "" >> return (Just p) ) `catch` (\(_ :: SomeException) -> - eprint ("Can't unpack " ++ mod) >> return Nothing + eprint ("Can't unpack " <> mod) >> return Nothing ) unpackModules :: [FilePath] -> IO [FilePath] unpackModules ms = catMaybes <$> mapM unpackModule ms + getFiles :: IO (Set Text) + getFiles = do + dirs <- readDirFile + ss_local <- mappend <$> readSourceFile <*> findSources dirs + when (null ss_local) $ + fail $ "Haskdogs were not able to find any sources in " <> intercalate ", " dirs + ss_l1deps <- findModules ss_local >>= inames2modules >>= unpackModules >>= findSources + return $ Set.filter (/= "-") ss_local `mappend` ss_l1deps + gentags :: IO () gentags = do checkapp "hasktags" - files <- do - dirs <- readDirFile - ss_local <- Set.union <$> readSourceFile <*> findSources dirs - when (null ss_local) $ do - fail $ "Haskdogs were not able to find any sources in " <> (intercalate ", " dirs) - ss_l1deps <- findModules ss_local >>= inames2modules >>= unpackModules >>= findSources - return $ ss_local `mappend` ss_l1deps - case cli_raw_mode of - True -> do - forM_ (Set.toList files) $ \f-> do - putStrLn f - False -> do - sfiles <- pure $ unlines $ Set.toList files - vprint sfiles - runp "hasktags" ((if null cli_hasktags_args then def_hasktags_args else cli_hasktags_args) ++ ["STDIN"]) sfiles + files <- getFiles + if cli_raw_mode + then + forM_ (Set.toList files) Text.putStrLn + else do + let sfiles = Text.unlines $ Set.toList files + vprint (unpack sfiles) + runp "hasktags" ((if null cli_hasktags_args then defHasktagsArgs else cli_hasktags_args) <> ["STDIN"]) sfiles putStrLn "\nSuccess" {- _real_main_ -} gentags - -