mcm-0.6.8.1: mcmtags.hs

-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2018 Anthony Doggett <mcm@interfaces.org.uk>
--
-- Licence:
--     This program is free software: you can redistribute it and/or modify
--     it under the terms of the GNU General Public License as published by
--     the Free Software Foundation, either version 3 of the License, or
--     (at your option) any later version.
--
--     This program is distributed in the hope that it will be useful,
--     but WITHOUT ANY WARRANTY; without even the implied warranty of
--     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--     GNU General Public License for more details.
--
--     You should have received a copy of the GNU General Public License
--     along with this program.  If not, see <http://www.gnu.org/licenses/>.

-- Parses all .mcm files below the current directory
-- (If directories given as arguments, uses those instead)
-- Writes the results to "tags" file (in current directory)
-- Prints warnings for any files that fail to parse
module Main (main)
where

import Parser (mcmParse)
import ParserTypes (Define(..), Section(..), MCMFile(..), DefName(..))
import Paths_mcm (version)

import Control.Monad (filterM, unless)
import Data.Char (isAsciiUpper)
import Data.List (isSuffixOf, intercalate, sort, foldl', nub)
import Data.Version (showVersion)
import qualified Data.Map as Map
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as TextIO
import System.Console.GetOpt
import System.Directory (getDirectoryContents)
import System.Environment (getArgs)
import System.Exit (exitSuccess)
import System.FilePath (joinPath)
import System.Posix.Files (getFileStatus, isDirectory)

usage :: String
usage = unlines ["Usage: mcmtags [DIR..]"
                ,"Parse all *.mcm files below the current directory,"
                ,"or if directories given as arguments, below those directories."
                ,"The resulting tags are written to ./tags."
                ,"Print warnings for any files that fail to parse."
                ,""
                ,"TAGTYPE\t\tsimple|qualified|both"
                ]

toWarn :: FilePath -> String
toWarn f = "WARNING: failed to parse " ++ f

tryParse :: FilePath -> IO (Maybe MCMFile)
tryParse f = do
    ss <- TextIO.readFile f
    case mcmParse ss of
        Right a -> return $ Just a
        Left _ -> return Nothing

makeTag :: FilePath -> String -> String -> String
makeTag f n ex_cmd = n ++ "\t" ++ f ++ "\t" ++ ex_cmd

toTags :: TagType -> (FilePath, MCMFile) -> [String]
toTags tagtype (f, MCMFile pp (Section _ _ ds)) = makePTags ++ concatMap makeDTags (Map.elems ds)
    where
        makePTags = case tagtype of
                        TTsimple -> [ppTag]
                        TTqualified -> [ppFullTag]
                        TTboth -> nub [ppTag, ppFullTag]
        ppTag = makeTag f (lastBitOfPath (show pp)) "/^MCM/"
        ppFullTag = makeTag f (show pp) "/^MCM/"
        makeDTags :: Define -> [String]
        makeDTags d = case tagtype of
                        TTsimple -> [dsTag d]
                        TTqualified -> [qualTag d]
                        TTboth -> [dsTag d, qualTag d]
        dsTag :: Define -> String
        dsTag d = makeTag f (strDefName d) (definesearch d)
        qualTag :: Define -> String
        qualTag d = makeTag f (show pp ++ '.':strDefName d) (definesearch d)
        definesearch :: Define -> String
        definesearch d = "/^define " ++ strDefName d ++ "(/"
        lastBitOfPath :: String -> String
        lastBitOfPath = reverse . takeWhile (/= '.') . reverse
        strDefName = T.unpack . fromDefName . defName

isDirectory' :: FilePath -> IO Bool
isDirectory' f = do
    s <- getFileStatus f
    return $ isDirectory s

findMcm :: FilePath -> IO [FilePath]
findMcm p = do
    allfiles <- getDirectoryContents p
    let fs = [f | f <- allfiles, f `notElem` [".", ".."]]
        ms = [joinPath [p,f] | f <- fs, ".mcm" `isSuffixOf` f]
        ds = [joinPath [p,f] | f <- fs, isAsciiUpper (head f), '.' `notElem` f]
    dirs <- filterM isDirectory' ds
    children <- mapM findMcm dirs
    return $ ms ++ concat children

splitParsed :: [(FilePath, Maybe MCMFile)] -> ([FilePath], [(FilePath, MCMFile)])
splitParsed [] = ([], [])
splitParsed ((fp, m):xs) =
    let (as, bs) = splitParsed xs
    in case m of
            Nothing -> (fp:as, bs)
            Just f -> (as, (fp, f):bs)

main :: IO ()
main = do
    args <- getArgs
    let (actions, nonOpts, msgs) = getOpt Permute options args
    unless (null msgs) $ error $ concat msgs ++ usageInfo usage options
    opts <- foldl' (>>=) (return defaultOptions) actions
    let Options {optTagType = tagtype} = opts
    let toRecurse = case nonOpts of
                        [] -> ["."]
                        ps -> ps
    toParse <- mapM findMcm toRecurse
    let toParse' = concat toParse
    parsed <- mapM tryParse toParse'
    let fparsed = zip toParse' parsed
    let (bad, good) = splitParsed fparsed
        tags = sort $ concatMap (toTags tagtype) good
    mapM_ (putStrLn . toWarn) bad
    writeFile "tags" $ intercalate "\n" tags
    return ()

data TagType = TTsimple | TTqualified | TTboth

data Options = Options {optTagType :: TagType}

defaultOptions :: Options
defaultOptions = Options {optTagType = TTboth}

options :: [OptDescr (Options -> IO Options)]
options = [Option "V" ["version"] (NoArg displayVersion) "show version and exit"
          ,Option "h" ["help"] (NoArg justHelp) "show this help and exit"
          ,Option "t" ["tag-type"] (ReqArg tagType "TAGTYPE") "type of tag to output (default = \"both\")"
          ]

displayVersion :: Options -> IO Options
displayVersion _ = do
    putStrLn $ "mcmtags " ++ showVersion version
    exitSuccess

justHelp ::  Options -> IO Options
justHelp _ = do
    putStrLn $ usageInfo usage options
    exitSuccess

tagType :: String -> Options -> IO Options
tagType "simple" opt = return opt {optTagType = TTsimple}
tagType "qualified" opt = return opt {optTagType = TTqualified}
tagType "both" opt = return opt {optTagType = TTboth}
tagType tt _ = error ("Unrecognised tag type: " ++ tt ++ "\n" ++ usageInfo usage options)