haskdogs-0.4.4: src/Main.hs

{-# LANGUAGE RecordWildCards, ScopedTypeVariables, ViewPatterns #-}
module Main (main) where

import Control.Monad
import Control.Applicative
import Control.Exception
import Data.Maybe
import Data.List
import System.IO
import System.Directory
import System.Process (readProcess)
import System.FilePath

import Data.Set (Set)
import qualified Data.Set as Set
import Options.Applicative
import qualified Options.Applicative as O
import Data.Version (showVersion)
import qualified Paths_haskdogs as Paths

{-
  ___        _   _
 / _ \ _ __ | |_(_) ___  _ __  ___
| | | | '_ \| __| |/ _ \| '_ \/ __|
| |_| | |_) | |_| | (_) | | | \__ \
 \___/| .__/ \__|_|\___/|_| |_|___/
      |_|
-}

data Opts = Opts {
    cli_dirlist_file :: FilePath
  , cli_filelist_file :: FilePath
  , cli_hasktags_args1 :: String
  , cli_ghc_pkgs_args :: String
  , cli_use_stack :: Tristate
  -- , cli_use_sandbox :: Tristate
  , cli_hasktags_args2 :: [String]
  } deriving(Show)

data Tristate = ON | OFF | AUTO
  deriving(Eq, Ord, Show, Read)

def_hasktags_args = words "-c -x"

optsParser :: Parser Opts
optsParser = Opts
  <$> strOption (
        long "dir-list" <>
        short 'd' <>
        metavar "FILE" <>
        value "" <>
        help "File containing directory list to process" )
  <*> strOption (
        long "file-list" <>
        short 'f' <>
        metavar "FILE" <>
        value "" <>
        help "File containing Haskell sources to process" )
  <*> strOption (
        long "hasktags-args" <>
        metavar "OPTS" <>
        value "" <>
        help ("Arguments to pass to hasktags. " ++ unwords def_hasktags_args ++ " is the default"))
  <*> strOption (
        long "ghc-pkg-args" <>
        metavar "OPTS" <>
        value "" <>
        help "Arguments to pass to ghc-pkgs")
  <*> option auto (
        long "use-stack" <>
        value AUTO <>
        help "Execute ghc-pkg via stack, arg is ON, OFF or AUTO (the default)")
  -- <*> option auto (
  --       long "include-sandbox" <>
  --       value AUTO <>
  --       help "(!UNIMPLEMENTED!) Include .cabal-sandbox package databases")
  <*> many (argument str (metavar "OPTS" <> help "More hasktags options, use `--' to pass flags starting with `-'"))

exename :: String
exename = "haskdogs"

versionParser :: Parser (a -> a)
versionParser = infoOption (exename ++ " version " ++ (showVersion Paths.version))
                     (long "version" <> help "Show version number")

opts = info (helper <*> versionParser <*> optsParser)
      ( fullDesc <> header (exename ++ " - Recursive hasktags-based TAGS generator for a Haskell project" ))

{-
 __  __       _
|  \/  | __ _(_)_ __
| |\/| |/ _` | | '_ \
| |  | | (_| | | | | |
|_|  |_|\__,_|_|_| |_|

-}

main :: IO()
main = do

  Opts {..} <- execParser opts

  let
    -- Directory to unpack sources into
    getDataDir :: IO FilePath
    getDataDir = do
      x <- (</> ".haskdogs") <$> getHomeDirectory
      createDirectoryIfMissing False x
      return x

    cli_verbose = True

    vprint a
      | cli_verbose = eprint a
      | otherwise = return ()

    eprint = hPutStrLn stderr

    runp nm args inp = do
      vprint $ "> " ++ nm ++ " " ++ unwords args
      readProcess nm args inp

    -- Run GNU which tool
    checkapp :: String -> IO ()
    checkapp appname = do
      (runp "which" [appname] [] >> return ()) `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)

  cwd <- getCurrentDirectory
  datadir <- getDataDir
  has_stack <- hasapp "stack"

  let

    readLinedFile f =
      lines <$> (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 = return []
      | otherwise = readLinedFile cli_dirlist_file

    readSourceFile :: IO (Set FilePath)
    readSourceFile
      | null cli_filelist_file = return Set.empty
      | otherwise = Set.fromList <$> readLinedFile cli_filelist_file

    cli_hasktags_args = (words cli_hasktags_args1) ++ cli_hasktags_args2

    runp_ghc_pkgs args = go cli_use_stack where
      go ON = runp "stack" (["exec", "ghc-pkg", "--"] ++ (words cli_ghc_pkgs_args) ++ args) []
      go OFF = runp "ghc-pkg" (words cli_ghc_pkgs_args ++ args) []
      go AUTO = if has_stack then go ON else go OFF

    cabal_or_stack = go cli_use_stack where
      go ON = "stack"
      go OFF = "cabal"
      go AUTO = if has_stack then go ON else go OFF

    -- Finds *hs in dirs, but filter-out Setup.hs
    findSources :: [FilePath] -> IO (Set FilePath)
    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 )") []

    grepImports :: String -> Maybe String
    grepImports line = case words line of
        ("import":"qualified":x:_) -> Just (filter (/=';') x)
        ("import":x:_) -> Just (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) []

    -- Maps import name to haskell package name
    iname2module :: String -> IO (Maybe String)
    iname2module iname = do
        mod <- (listToMaybe . words) <$> (runp_ghc_pkgs ["--simple-output", "find-module", iname])
        vprint $ "Import " ++ iname ++ " resolved to " ++ (fromMaybe "NULL" mod)
        return mod

    inames2modules :: [String] -> IO [FilePath]
    inames2modules is = nub . sort . catMaybes <$> forM (nub is) iname2module

    -- Unapcks haskel package to the sourcedir
    unpackModule :: FilePath -> IO (Maybe FilePath)
    unpackModule mod = do
        let p = datadir</>mod
        exists <- doesDirectoryExist p
        case exists of
          True ->  do
            vprint $ "Already unpacked " ++ mod
            return (Just p)
          False -> do
            bracket_ (setCurrentDirectory datadir) (setCurrentDirectory cwd) $
              ( runp cabal_or_stack ["unpack", mod] [] >> return (Just p)
              ) `catch`
              (\(_ :: SomeException) ->
                eprint ("Can't unpack " ++ mod) >> return Nothing
              )

    unpackModules :: [FilePath] -> IO [FilePath]
    unpackModules ms = catMaybes <$> mapM unpackModule ms

    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
      runp "hasktags" ((if null cli_hasktags_args then def_hasktags_args else cli_hasktags_args) ++ Set.toList files) []
      putStrLn "\nSuccess"

  {- _real_main_ -}
  gentags