htags-1.0: src/htags.hs

{-# OPTIONS_GHC -Wall #-}
module Main(main) where
import Language.Haskell.Syntax
import Language.Haskell.Parser
import Control.Applicative
import System.Environment
import Tag
import GenTags
import Data.Maybe
import System.Console.GetOpt
import Control.Monad.Error
import System.Directory
import System.FilePath
import Control.Arrow( first, second )

--
-- Options datatype
--
data Options = Options { optRecurse :: Bool
                       , optShowHelp :: Bool
                       }
  deriving Show

defaultOptions ::  Options
defaultOptions = Options False False

setRecurse :: Bool -> Options -> Options
setRecurse b o = o { optRecurse = b }

showHelp :: Options -> Options
showHelp o = o { optShowHelp = True }

--
-- Special Yes/No Option
--

ynb :: (Monad m) => String -> m Bool
ynb "yes" = return True
ynb "no" = return False
ynb _ = error "Invalid (yes|no) thing"


yesNoArg :: (Monad m) => (Bool -> a -> b) -> Bool -> ArgDescr (a -> m b)
yesNoArg z def = OptArg f "yes|no"
  where
    f = maybe (return . z def) (\a opt -> ynb a >>= return . flip z opt)

--
-- Our options list
--

options ::  [OptDescr (Options -> Either String Options)]
options = [ Option "R" ["recurse"] (yesNoArg setRecurse True)
                "Recurse into directories supplied on command line [no]."
          , Option "" ["help"] (NoArg (fmap return showHelp))
                "Print this option summary."
          ]

parseOpts ::  [String] -> -- command line arguments
              Either 
                 String -- Error message
                 ( Options   -- Options
                 , [String] ) -- List of files
parseOpts s = errM >> optsM >>= return . flip (,) nonopts
  where (args, nonopts, errors) = getOpt Permute options s
        optsM = foldM (flip ($)) defaultOptions args
        errM = sequence_ (fmap error errors)
 
prgName :: String
prgName = "htags"

outputUsage ::  IO ()
outputUsage = putStr (usageInfo prgName options)

--
-- File Path utilities
--
getLeavesL :: [String] -> IO [String]
getLeavesL = fmap concat . mapM getLeaves

-- Like getDirectoryContents, but returns relative paths
childPaths ::  FilePath -> IO [FilePath]
childPaths s = do contents <- getDirectoryContents s
                  return (fmap (combine s) (filter (flip notElem [".",".."]) contents))
         
getLeaves :: String -> IO [String]
getLeaves s = do isDir <- doesDirectoryExist s
                 if isDir then childPaths s >>= getLeavesL
                          else (pure.pure) s
                      
-- Given a list of directories and files, returns a list of haskell source
-- files optionally recursing.
getHsFiles :: Bool -> [String] -> IO [String]
getHsFiles False files = return (filterHs files)
getHsFiles True files = fmap filterHs (getLeavesL files)

filterHs :: [String] -> [String]
filterHs = filter isHaskellFile

isHaskellFile :: String -> Bool
isHaskellFile = flip elem haskellExtensions . takeExtension

haskellExtensions ::  [String]
haskellExtensions = [".hs", ".lhs"]

run :: Options -> [String] -> IO ()
run os files = do when (optShowHelp os) outputUsage
                  fs <- getHsFiles (optRecurse os) files
                  (errors, tags) <- fmap pullout (mapM yar fs)
                  mapM_ (putStrLn . (++) "Parse Error: " . show) errors
                  writeFile "tags" (tagsToTagfile (concat tags))
  where
    yar ::  String -> IO (Either (SrcLoc, String) [Tag])
    yar = (fmap.fmap.fmap) modToTags parseFile

main ::  IO ()
main = fmap parseOpts getArgs >>= either print (uncurry run)

--
-- Utility Functions
--

parseFile :: String -> IO (Either (SrcLoc, String) HsModule)
parseFile = (fmap.fmap) prToEither pf
  where
    pf :: String -> IO (ParseResult HsModule)
    pf = liftA2 fmap (parseModuleWithMode . ParseMode) readFile
    -- Convert ParseResult to an Either
    prToEither :: ParseResult HsModule -> Either (SrcLoc, String) HsModule
    prToEither s = case s of ParseFailed loc str -> Left (loc,str)
                             ParseOk m           -> Right m

pullout :: [Either a b] -> ([a], [b])
pullout [] = ([], [])
pullout (Left a:z) = first (a:) (pullout z)
pullout (Right a:z) = second (a:) (pullout z)

-- TODO: In order of importance
-- - Allow it to work with cabal files?
-- - Allow it to parse module names for tagging.
-- - Make it work with search strings (like exuberant C tags)
-- - Allow it to work with qualified modules local to a file? (Check out the info on extended syntax)
-- - Allow it to take many command line arguments for names.