module Main where
import System
import Char
import List
import IO
import Monad
import Directory

-- search for definitions of things 
-- we do this by looking for the following patterns:
-- data XXX = ...      giving a datatype location
-- newtype XXX = ...   giving a newtype location
-- bla :: ...          giving a function location
--
-- by doing it this way, we avoid picking up local definitions
--      (whether this is good or not is a matter for debate)
--

-- We generate both CTAGS and ETAGS format tags files
-- The former is for use in most sensible editors, while EMACS uses ETAGS

-- Srineet (18th Aug 2004):
----------------------------
-- added support for tagging class names
-- add support for usage help
-- add support for recursing directories
-- todo: need to sort tags
-- removed creation of emacs tags files (only vi format).
    -- The function to do that - writeetagsfile, is present but never used.
-- Will now work only on Windows (change delim to '/' and it should work on unix)
-- I build this using command "ghc myhasktags.hs"

main :: IO ()
main = do
    argStrings <- getArgs
    processArgs argStrings

usage :: String
usage =   "Usage:\n" ++
      "myhasktags -R <dirname>    (will tag all .hs and .lhs files recursively) \n" ++
      "myhasktags <filenames>     (will tag the files listed)\n\n" ++
      "Always creates a file called tags in the current directory in vi format.\n" ++
      "The tags are not sorted. I get around this by setting the ignorecase option in vi.\n"

-- path delimiter. Change it to suit your system.
delim = '\\'

-- "worker function" that processes arguments and does the needful
processArgs :: [String] -> IO ()
processArgs xs = if (null xs) || ("-h" `elem` xs) || ("--help" `elem` xs) || ("-?" `elem` xs) || ("/?" `elem` xs) then
            putStrLn usage
         else if head xs == "-R" then
                if length xs == 2 then      
                    recurseAndBuildTags WriteMode $ stripLastDelim (xs !! 1)
                else
                    putStrLn usage
              else
                  tagFileList xs WriteMode


-- function that, given a directory path, creates a tags file by recursing and looking for .hs and .lhs files
recurseAndBuildTags :: IOMode -> String -> IO ()
recurseAndBuildTags mode path =  do
    putStrLn ("--> " ++ path)
    contents <- getDirectoryContents path
    let contents' =  map (\child -> path ++ "\\" ++ child) (filter (\d -> d /= "." && d /= "..") contents) 
    (dirs, files) <- partitionM isThisADir contents'
    let exths name = let rev = reverse name in ((toUpperS $ take 4 rev) == "SHL.")  || ((toUpperS $ take 3 rev) == "SH.")
    let files' = filter exths files
    tagFileList files' mode
    sequence_ $ map (recurseAndBuildTags AppendMode) dirs

-- Function that takes a list of files and creates a tags file
tagFileList :: [FileName]  -> IOMode -> IO ()
tagFileList filenames mode = do
    filedata <- mapM findthings filenames
    ctagsfile <- openFile "tags" mode
    writectagsfile ctagsfile filedata
    hClose ctagsfile

type FileName = String

type ThingName = String

-- The position of a token or definition
data Pos = Pos 
        FileName    -- file name
        Int         -- line number 
        Int         -- token number
        String      -- string that makes up that line
    deriving Show

-- A definition we have found
data FoundThing = FoundThing ThingName Pos
    deriving Show

-- Data we have obtained from a file
data FileData = FileData FileName [FoundThing]
    deriving Show

data Token = Token String Pos
    deriving Show


-- stuff for dealing with ctags output format

writectagsfile :: Handle -> [FileData] -> IO ()
writectagsfile ctagsfile filedata = do
    let things = concat $ map getfoundthings filedata
    mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things

getfoundthings :: FileData -> [FoundThing]
getfoundthings (FileData filename things) = things

dumpthing :: FoundThing -> String
dumpthing (FoundThing name (Pos filename line _ _)) = 
    name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)


-- stuff for dealing with etags output format

writeetagsfile :: Handle -> [FileData] -> IO ()
writeetagsfile etagsfile filedata = do
    mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata

e_dumpfiledata :: FileData -> String
e_dumpfiledata (FileData filename things) = 
    "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
    where 
        thingsdump = concat $ map e_dumpthing things 
        thingslength = length thingsdump

e_dumpthing :: FoundThing -> String
e_dumpthing (FoundThing name (Pos filename line token fullline)) =
    (concat $ take (token + 1) $ spacedwords fullline) 
    ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
    
    
-- like "words", but keeping the whitespace, and so letting us build
-- accurate prefixes    
    
spacedwords :: String -> [String]
spacedwords [] = []
spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
    where 
        (blanks,rest) = span Char.isSpace xs
        (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
    
    
-- Find the definitions in a file   
    
findthings :: FileName -> IO FileData
findthings filename = do
    putStrLn ("--> " ++ filename)
    text <- readFile filename
    let aslines = lines text
    let wordlines = map words aslines
    let noslcoms = map stripslcomments wordlines
    let tokens = concat $ zipWith3 (withline filename) noslcoms 
                    aslines [0 ..]
    let nocoms = stripblockcomments tokens
    return $ FileData filename $ findstuff nocoms
    
-- Create tokens from words, by recording their line number
-- and which token they are through that line

withline :: FileName -> [String] -> String -> Int -> [Token]        
withline filename words fullline i = 
    zipWith (\w t -> Token w (Pos filename i t fullline)) words $ [0 ..]

-- comments stripping

stripslcomments :: [String] -> [String]
stripslcomments (x:xs) | isPrefixOf "--" x = []
                       | otherwise = x : stripslcomments xs
stripslcomments [] = []

stripblockcomments :: [Token] -> [Token]
stripblockcomments ((Token "\\end{code}" _):xs) = 
    stripblockcomments $ afterlitend xs
stripblockcomments ((Token "{-" _):xs) = 
    stripblockcomments $ afterblockcomend xs
stripblockcomments (x:xs) = x:stripblockcomments xs
stripblockcomments [] = []

afterlitend2 :: [Token] -> [Token]
afterlitend2 (x:xs) = afterlitend xs
afterlitend2 [] = []

afterlitend :: [Token] -> [Token]
afterlitend ((Token "\\begin{code}" _):xs) = xs
afterlitend (x:xs) = afterlitend xs
afterlitend [] = []

afterblockcomend :: [Token] -> [Token]
afterblockcomend ((Token token _):xs) | contains "-}" token = xs
                        | otherwise = afterblockcomend xs
afterblockcomend [] = []


-- does one string contain another string

contains :: Eq a => [a] -> [a] -> Bool
contains sub full = any (isPrefixOf sub) $ tails full 

ints :: Int -> [Int]
ints i = i:(ints $ i+1)


-- actually pick up definitions

findstuff :: [Token] -> [FoundThing]
findstuff ((Token "data" _):(Token name pos):xs) = 
    FoundThing name pos : (getcons xs) ++ (findstuff xs)
findstuff ((Token "newtype" _):(Token name pos):xs) = 
    FoundThing name pos : findstuff xs
findstuff ((Token "type" _):(Token name pos):xs) = 
    FoundThing name pos : findstuff xs
findstuff ((Token name pos):(Token "::" _):xs) = 
    FoundThing name pos : findstuff xs
-- (srineet) added by me for class support
findstuff ((Token "class" pos):xs) =
    getclassname xs ++ findstuff xs
findstuff (x:xs) = findstuff xs
findstuff [] = []


-- get the constructor definitions, knowing that a datatype has just started

getcons :: [Token] -> [FoundThing]
getcons ((Token "=" _):(Token name pos):xs) = 
    FoundThing name pos : getcons2 xs
getcons (x:xs) = getcons xs
getcons [] = []


getcons2 ((Token "=" _):xs) = []
getcons2 ((Token "|" _):(Token name pos):xs) = 
    FoundThing name pos : getcons2 xs
getcons2 (x:xs) = getcons2 xs
getcons2 [] = []

-- (srineet) get the class name, knowing that we've seen a class declaration.
-- find the last before where that starts with a upper case letter.

getclassname [] = []

getclassname l@(x:xs) = let
    isNotWhereOrEqual (Token "where" _)   = False
    isNotWhereOrEqual (Token "=" _)       = False
    isNotWhereOrEqual _                   = True

    uptoWhere   = takeWhile (isNotWhereOrEqual ) l
    in case filter (\(Token name _) -> (isUpper.head) name) (reverse uptoWhere) of
                        []  -> []
                        ((Token name pos):_) -> [(FoundThing name pos)]

-- monadic version of partition
partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ( [a], [a] )
partitionM check xs =  ( liftM2 (,) ) (filterM check xs) (filterM ((liftM not).check) xs) 

-- function to check whether this is a directory (if not, we assume it is a file)
isThisADir :: String -> IO Bool
isThisADir path = do
    curDir <- getCurrentDirectory 
    result <- try (setCurrentDirectory path)
    case result of
        Left _ ->  do
            setCurrentDirectory curDir
            return False
        _      -> do
            setCurrentDirectory curDir
            return True

-- toUpper for string
toUpperS :: String -> String
toUpperS = map toUpper

-- strip the last delimiter (if any) from a path
stripLastDelim :: String -> String
stripLastDelim path | last path == delim    = take (length(path) - 1) path
                    | otherwise         = path