4 patches for repository http://code.haskell.org/hasktags: Mon Feb 7 23:37:30 CET 2011 Daniel Schüssler * Add recursive mode Tue Feb 8 00:17:23 CET 2011 Daniel Schüssler * add some cost centres for profiling Tue Feb 8 01:12:07 CET 2011 Daniel Schüssler * replace (the quadratic) nubBy by a Data.Map-based algorithm Tue Feb 8 01:50:24 CET 2011 Daniel Schüssler * fix relative path problem in recursive mode by using absolute paths, for now New patches: [Add recursive mode Daniel Schüssler **20110207223730 Ignore-this: 687f65c620f4f6e50b4452916facf87 ] { addfile ./Recursive.hs hunk ./Recursive.hs 1 +{-# OPTIONS -Wall #-} +module Recursive(Directory,AbstractNonRecOperations(..),recMain) where + +import System.Directory.Tree +import Data.List +import Data.Monoid +import System.FilePath + +type Directory = FilePath + +-- Avoid import cycle by abstracting the stuff we need from main.hs +data AbstractNonRecOperations fileData = AbstractNonRecOperations { + absFindThings :: FilePath -> IO fileData, + absWriteTags :: Directory -> [fileData] -> IO (), + absPrintDebug :: String -> IO (), + absPrintInfo :: String -> IO (), + absPrintWarning :: String -> IO (), + absCountThings :: fileData -> Int +} + +data Counted a = Counted { + cThings :: Int, + cFiles :: Int, + cValue :: a +} + +instance Monoid a => Monoid (Counted a) where + mempty = Counted 0 0 mempty + mappend (Counted n1 m1 x1) (Counted n2 m2 x2) = Counted (n1+n2) (m1+m2) (x1 `mappend` x2) + + +isZero :: Counted a -> Bool +isZero = (==0) . cThings + + +recMain :: AbstractNonRecOperations fileData -> Directory -> IO () +recMain ops root = do + atree0 <- readDirectoryWithL maybeReadInFile root + _ <- walkTree atree0 + return () + where + maybeReadInFile x + | any (`isSuffixOf` x) [".hs",".lhs"] = do + fileData <- absFindThings ops x + let count = absCountThings ops fileData + absPrintInfo ops (x ++ spacer ++ "Read " ++ pluralized count "declaration") + return (Counted { cThings = count + , cFiles = 1 + , cValue = [fileData] }) + + | otherwise = return mempty + + walkTree (base :/ subtree) = + case subtree of + File {file=c} -> return c + + + Dir {name=name_,contents=contents_} -> do + let path = base name_ + fileDatas <- mconcat `fmap` mapM (walkTree . (path :/)) contents_ + if (isZero fileDatas) + then absPrintDebug ops (path ++ spacer ++ "Nothing taggable") + else do + absWriteTags ops path (cValue fileDatas) + absPrintInfo ops ( path ++ spacer + ++ "Wrote tags for a total of " + ++ pluralized (cThings fileDatas) "declaration" + ++ " from " + ++ pluralized (cFiles fileDatas) "file" + ) + return fileDatas + + Failed {name=name_,err=err_} -> do + absPrintWarning ops + ( (basename_) ++ spacer + ++ show err_ + ++ " (Continuing anyway)" ) + return mempty + + +pluralized :: Int -> String -> String +pluralized 1 entity = "1 "++entity +pluralized n entity = show n ++ " " ++ entity ++ "s" + +spacer :: String +spacer = "\v " -- replicate 8 ' ' hunk ./hasktags.cabal 23 Executable hasktags Main-Is: hasktags.hs - Build-Depends: haskell98, base < 5, bytestring + Other-modules: Recursive + Build-Depends: haskell98, base < 5, bytestring, directory-tree, filepath hunk ./hasktags.hs 12 import System.Environment import System.Console.GetOpt import System.Exit +import System.FilePath(()) --import Debug.Trace hunk ./hasktags.hs 15 +import Recursive +import Control.Exception(finally) + -- search for definitions of things -- we do this by looking for the following patterns: hunk ./hasktags.hs 76 putStr $ usageInfo usageString options exitWith (ExitFailure 1)) + checkConflictingModes modes + let mode = getMode (filter ( `elem` [BothTags, CTags, ETags, Append] ) modes) openFileMode = if elem Append modes then AppendMode hunk ./hasktags.hs 82 else WriteMode - filedata <- mapM (findthings (IgnoreCloseImpl `elem` modes)) filenames hunk ./hasktags.hs 83 - when (mode == CTags) - (do ctagsfile <- getOutFile "tags" openFileMode modes - writectagsfile ctagsfile (ExtendedCtag `elem` modes) filedata - hClose ctagsfile) + findthings' = findthings (IgnoreCloseImpl `elem` modes) + writectagsfile' ctagsfile = writectagsfile ctagsfile (ExtendedCtag `elem` modes) + + + if Recursive `elem` modes + then + let + ops = AbstractNonRecOperations { + absFindThings = findthings' + , absWriteTags = \dir filedatas -> do + + let withOpenFile fn act = do + h <- openFile (dir fn) openFileMode + act h `finally` hClose h + + -- stdout issue mentioned in the nonrecursive mode below doesn't apply, + -- since output is never redirected in recursive mode + + when (mode == CTags || mode == BothTags) + (withOpenFile "tags" (flip writectagsfile' filedatas)) + + when (mode == ETags || mode == BothTags) + (withOpenFile "TAGS" (flip writeetagsfile filedatas)) + + , absPrintDebug = putStrLn + , absPrintInfo = putStrLn + , absPrintWarning = putStrLn + , absCountThings = \(FileData _ things) -> length things + } + in + mapM_ (recMain ops) filenames + hunk ./hasktags.hs 116 - when (mode == ETags) - (do etagsfile <- openFile "TAGS" openFileMode - writeetagsfile etagsfile filedata - hClose etagsfile) + else do + filedata <- mapM findthings' filenames hunk ./hasktags.hs 119 - -- avoid problem when both is used in combination - -- with redirection on stdout - when (mode == BothTags) - (do etagsfile <- getOutFile "TAGS" openFileMode modes - writeetagsfile etagsfile filedata - ctagsfile <- getOutFile "tags" openFileMode modes - writectagsfile ctagsfile (ExtendedCtag `elem` modes) filedata - hClose etagsfile - hClose ctagsfile) + when (mode == CTags) + (do ctagsfile <- getOutFile "tags" openFileMode modes + writectagsfile' ctagsfile filedata + hClose ctagsfile) + + when (mode == ETags) + (do etagsfile <- openFile "TAGS" openFileMode + writeetagsfile etagsfile filedata + hClose etagsfile) + + -- avoid problem when both is used in combination + -- with redirection on stdout + when (mode == BothTags) + (do etagsfile <- getOutFile "TAGS" openFileMode modes + writeetagsfile etagsfile filedata + ctagsfile <- getOutFile "tags" openFileMode modes + writectagsfile' ctagsfile filedata + hClose etagsfile + hClose ctagsfile) -- | getMode takes a list of modes and extract the mode with the -- highest precedence. These are as follows: Both, CTags, ETags hunk ./hasktags.hs 156 getOutFile defaultName openMode [] = openFile defaultName openMode data Mode = ExtendedCtag - | IgnoreCloseImpl + | IgnoreCloseImpl | ETags | CTags | BothTags hunk ./hasktags.hs 162 | Append | OutRedir String + | Recursive | Help deriving (Ord, Eq, Show) hunk ./hasktags.hs 176 , Option "a" ["append"] (NoArg Append) "append to existing CTAGS and/or ETAGS file(s)" , Option "" ["ignore-close-implementation"] - (NoArg IgnoreCloseImpl) "ignores found implementation if its closer than 7 lines - so you can jump to definition in one shot" + (NoArg IgnoreCloseImpl) "ignores found implementation if it's closer than 7 lines - so you can jump to definition in one shot" , Option "o" ["output"] (ReqArg OutRedir "") "output to given file, instead of 'tags', '-' file is stdout" , Option "f" ["file"] hunk ./hasktags.hs 183 (ReqArg OutRedir "") "same as -o, but used as compatibility with ctags" , Option "x" ["extendedctag"] (NoArg ExtendedCtag) "Generate additional information in ctag file." + , Option "r" ["recursive"] + (NoArg Recursive) "For *each* subdirectory D of the argument directory, this command will write a 'tags' and/or 'TAGS' file containing the tags for all the .hs and .lhs files in *or below* D (exception: no empty tag files are written). In other words, every source file will have its items listed in the tag file of every directory between the source file's directory and the base directory." , Option "h" ["help"] (NoArg Help) "This help" ] hunk ./hasktags.hs 543 then lines else literate + +checkConflictingModes modes = + when (Recursive `elem` modes && any isOutRedir modes) $ do + hPutStrLn stderr ("Can't use the output redirection option in recursive mode.") + exitWith (ExitFailure 2) + + + where + isOutRedir (OutRedir _) = True + isOutRedir _ = False + + {- testcase: checkToBeFound(){ } [add some cost centres for profiling Daniel Schüssler **20110207231723 Ignore-this: bf1a0acdbe8ba9b30063bd9377d5c2da ] { hunk ./hasktags.hs 308 -- Find the definitions in a file findthings :: Bool -> FileName -> IO FileData findthings ignoreCloseImpl filename = do - aslines <- fmap ( lines . evaluate . BS.unpack) $ BS.readFile filename + aslines <- {-# SCC "findthings/aslines" #-} + fmap ( lines . evaluate . BS.unpack) $ + {-# SCC "findthings/BS.readFile" #-} + BS.readFile filename let stripNonHaskellLines = let emptyLine = all (all isSpace . tokenString) hunk ./hasktags.hs 324 -- then remove {- -} comments -- split by lines again ( to get indent let (fileLines, numbers) = unzip . fromLiterate filename $ zip aslines [0..] - let tokenLines = + let tokenLines = {-# SCC "findthings/tokenLines" #-} stripNonHaskellLines $ stripslcomments $ splitByNL Nothing hunk ./hasktags.hs 343 -- let x = 7 -- z = 20 -- won't be found as function - let sections = map tail -- strip leading NL (no longer needed + let sections = {-# SCC "findthings/sections" #-} + map tail -- strip leading NL (no longer needed $ filter (not . null) $ splitByNL (Just (getTopLevelIndent tokenLines) ) $ concat tokenLines hunk ./hasktags.hs 351 -- only take one of -- a 'x' = 7 -- a _ = 0 - let filterAdjacentFuncImpl = nubBy (\(FoundThing t1 n1 (Pos f1 _ _ _)) + let filterAdjacentFuncImpl = {-# SCC "findthings/findAdjacentFuncImpl" #-} + nubBy (\(FoundThing t1 n1 (Pos f1 _ _ _)) (FoundThing t2 n2 (Pos f2 _ _ _)) -> f1 == f2 && n1 == n2 && t1 == FTFuncImpl && t2 == FTFuncImpl ) hunk ./hasktags.hs 356 - let iCI = if ignoreCloseImpl + let iCI = {-# SCC "findthings/iCI" #-} + if ignoreCloseImpl then nubBy (\(FoundThing _ n1 (Pos f1 l1 _ _)) (FoundThing _ n2 (Pos f2 l2 _ _)) -> f1 == f2 && n1 == n2 && ( ( <= 7 ) $ abs $ l2 - l1)) } [replace (the quadratic) nubBy by a Data.Map-based algorithm Daniel Schüssler **20110208001207 Ignore-this: 620e764373e807d0c1aa8ec28037b316 ] { hunk ./hasktags.cabal 24 Executable hasktags Main-Is: hasktags.hs Other-modules: Recursive - Build-Depends: haskell98, base < 5, bytestring, directory-tree, filepath + Build-Depends: haskell98, base < 5, bytestring, directory-tree, filepath, containers hunk ./hasktags.hs 6 import Data.Char import Data.List import Data.Maybe +import qualified Data.Map as M import Control.Monad( when ) import IO hunk ./hasktags.hs 353 -- a 'x' = 7 -- a _ = 0 let filterAdjacentFuncImpl = {-# SCC "findthings/findAdjacentFuncImpl" #-} - nubBy (\(FoundThing t1 n1 (Pos f1 _ _ _)) - (FoundThing t2 n2 (Pos f2 _ _ _)) - -> f1 == f2 && n1 == n2 && t1 == FTFuncImpl && t2 == FTFuncImpl ) + fastNub (\(FoundThing _ n1 (Pos f1 _ _ _)) -> (f1,n1)) + (\(FoundThing t1 _ _) + (FoundThing t2 _ _) + -> t1 == FTFuncImpl && t2 == FTFuncImpl ) + +-- nubBy (\(FoundThing t1 n1 (Pos f1 _ _ _)) +-- (FoundThing t2 n2 (Pos f2 _ _ _)) +-- -> f1 == f2 && n1 == n2 && t1 == FTFuncImpl && t2 == FTFuncImpl ) let iCI = {-# SCC "findthings/iCI" #-} if ignoreCloseImpl hunk ./hasktags.hs 364 - then nubBy (\(FoundThing _ n1 (Pos f1 l1 _ _)) - (FoundThing _ n2 (Pos f2 l2 _ _)) - -> f1 == f2 && n1 == n2 && ( ( <= 7 ) $ abs $ l2 - l1)) + then + + fastNub (\(FoundThing _ n1 (Pos f1 _ _ _)) -> (f1,n1)) + (\(FoundThing _ _ (Pos _ l1 _ _)) + (FoundThing _ _ (Pos _ l2 _ _)) + -> ( ( <= 7 ) $ abs $ l2 - l1)) + +-- nubBy (\(FoundThing _ n1 (Pos f1 l1 _ _)) +-- (FoundThing _ n2 (Pos f2 l2 _ _)) +-- -> f1 == f2 && n1 == n2 && ( ( <= 7 ) $ abs $ l2 - l1)) else id return $ FileData filename $ iCI $ filterAdjacentFuncImpl $ concatMap findstuff sections hunk ./hasktags.hs 411 -- Create tokens from words, by recording their line number -- and which token they are through that line +-- | @fastNub proj extraPred@ should be equivalent to +-- @'nubBy' (\x1 x2 -> proj x1 == proj x2 && extraPred x1 x2)@ +fastNub :: Ord b => (a -> b) -> (a -> a -> Bool) -> [a] -> [a] +fastNub proj extraPred xs0 = unfoldr f (M.empty,xs0) + where + f (index,xs) = + let + shouldDrop y = + case M.lookup (proj y) index of + Nothing -> False + Just bucket -> any (`extraPred` y) bucket + + in + case dropWhile shouldDrop xs of + [] -> Nothing + (y:ys) -> Just (y,(M.insertWith (++) (proj y) [y] index,ys)) + + + + withline :: FileName -> [String] -> String -> Int -> [Token] withline filename sourceWords fullline i = let countSpaces (' ':xs) = 1 + countSpaces xs } [fix relative path problem in recursive mode by using absolute paths, for now Daniel Schüssler **20110208005024 Ignore-this: 673887231f530fe84e961aec30030006 ] { hunk ./Recursive.hs 8 import Data.List import Data.Monoid import System.FilePath +import System.Directory(canonicalizePath) type Directory = FilePath hunk ./Recursive.hs 39 recMain :: AbstractNonRecOperations fileData -> Directory -> IO () recMain ops root = do - atree0 <- readDirectoryWithL maybeReadInFile root + atree0 <- readDirectoryWithL maybeReadInFile =<< canonicalizePath root _ <- walkTree atree0 return () where hunk ./hasktags.cabal 24 Executable hasktags Main-Is: hasktags.hs Other-modules: Recursive - Build-Depends: haskell98, base < 5, bytestring, directory-tree, filepath, containers + Build-Depends: directory, haskell98, base < 5, bytestring, directory-tree, filepath, containers } Context: [version bump to reflect base constraints update marco-oweber@gmx.de**20101210121826 Ignore-this: eb896f4ca21da733df6893212bfc7156 ] [use strict bytestring to read files. Hopefully this fixes the encoding errors I got by ignoring them (TODO: investigate and find a proper fix..) marco-oweber@gmx.de**20100106085726 Ignore-this: 3a318f69f7bf45fc8791c8e1a08f7a1c ] [allow base < 5. Hasktags is that simple. I don't expect any problems with newer base releases marco-oweber@gmx.de**20100105010947 Ignore-this: 3ffe6e8806952485395bdd5070170ba8 ] [Adding extended ctags output and better file handling. Removed all warning & hlint suggestions Vincent B **20091230111453 Ignore-this: 2ea10e3bc4000c0c8cf325119b5263d3 ] [add support for classes without functions (such as Throws used by Control.Monad.Exception) marco-oweber@gmx.de**20091221194526 Ignore-this: 8bdcd220f6ce0f06d1a75208bf21d697 ] [add new test case marco-oweber@gmx.de**20091213223743 Ignore-this: 9e958742dd3f214e6863228273dee74e ] [adding hasktags.cabal marco-oweber@gmx.de**20091129124829 Ignore-this: ae40f59ee87c5ca865694f6334308571 ] [adding TODO file marco-oweber@gmx.de**20090819075238 Ignore-this: 459080d443dbf0c55750dc7c8b8d9220 ] [Setup.hs marco-oweber@gmx.de**20090818113301 Ignore-this: 4a11a9aa745220ad0612b9cadb536354 ] [merged README stuff in from hackage version marco-oweber@gmx.de**20090818113109 Ignore-this: 9e26bff2c58d9a4d125956cf944d8c1 ] [adding license marco-oweber@gmx.de**20090818112630 Ignore-this: ca081bbd71c3bf2bdff81202635e997c ] [adding a README file marco-oweber@gmx.de**20090818112058 Ignore-this: c137bed383f54b389bbc78a46caf347d ] [read files strictly marco-oweber@gmx.de**20090812211533 Ignore-this: 775a413f9793bc4ab472ed091e17d1f ] [remove traceShow line marco-oweber@gmx.de**20090724215434 Ignore-this: b9d5af319de839c38f68ad1f470a66d2 ] [another test case marco-oweber@gmx.de**20090724204527 Ignore-this: e1ad4831f89aa936673278d39ab15352 ] [new testcase marco-oweber@gmx.de**20090724193437 Ignore-this: 187dc88288172358e5c7919f56c6830c ] [enhance test runner script marco-oweber@gmx.de**20090724193246 Ignore-this: d0ebab0d6b99c938a22f6d00e564c831 ] [find (@=:) :: Foo marco-oweber@gmx.de**20090724193208 Ignore-this: 1cca87508782b95db2d469b4c06c047 ] [find class name in => (ABCD a) (superfluous parenthesis marco-oweber@gmx.de**20090724193100 Ignore-this: 37b29f3330f7ded7ffa8c06b3edb92cc ] [fix comment from upstream marco-oweber@gmx.de**20090724193022 Ignore-this: e775cc61b845cbbd1c03289e499ce97e ] [quick dirty fix for Repair.lhs found in darcs repo marco-oweber@gmx.de**20081102225434] [removed debug line marco-oweber@gmx.de**20080520182146] [testcase files marco-oweber@gmx.de**20080520181358] [initial content marco-oweber@gmx.de**20080520173529] Patch bundle hash: 562d2f77791e6caacb63ddcd5031eb80b48da2fa