diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,12 +14,12 @@ Ctag format: ```bash -hasktags --ignore-close-implementation --ctags . +hasktags --ctags . ``` Etag format (used by emacs): ```bash -hasktags --ignore-close-implementation --etags . +hasktags --etags . ``` Both formats: @@ -36,6 +36,14 @@ ``` `:tjump foo` or such. See `:h` tags +You can use a configuration like [this one](../assets/hasktags.vim) +with [Tagbar](https://github.com/majutsushi/tagbar) to produce a +tagbar like this: + +![Tagbar1](../assets/tagbar1.png?raw=true) ![Tagbar2](../assets/tagbar2.png?raw=true) + +Enormous thanks to Alexey Radkov for the hierarchical design necessary for this usage. + ### NEdit Load the "tags" file using File/Load Tags File. Use "Ctrl-D" to search for a tag. @@ -68,8 +76,25 @@ Alex no longer supports bird style ">", so should we drop support, too? ## Contributors -- Tsuru Capital (github/liyang) -- Marco Túlio Pimenta Gontijo (github/marcotmarcot) +- Jack Henahan (maintainer) +- Marc Weber +- Marco Túlio Pimenta Gontijo +- Nikolay Yakimov +- Alois Cochard +- Liyang HU +- Ben Gamari +- Chris Done +- Chris Stryczynski +- Max Nordlund gmail +- Kwang Yul Seo +- Pedro Rodriguez +- Thomas Miedema +- Vincent B +- dnhgff +- Alexey Radkov +- Michael Baikov +- Magnus Therning +- Felix Gruber ## TODO Add all people having contributed before Oct 2012 @@ -77,9 +102,8 @@ having contributed when this repository has been part of ghc # Related work -List taken from announce of lushtags. - https://github.com/bitc/lushtags -- http://hackage.haskell.org/package/hasktags +- https://github.com/elaforge/fast-tags - http://kingfisher.nfshost.com/sw/gasbag/ - http://hackage.haskell.org/package/hothasktags - http://majutsushi.github.com/tagbar/ diff --git a/hasktags.cabal b/hasktags.cabal --- a/hasktags.cabal +++ b/hasktags.cabal @@ -1,5 +1,5 @@ Name: hasktags -Version: 0.69.5 +Version: 0.70.0 Copyright: The University Court of the University of Glasgow License: BSD3 License-File: LICENSE @@ -23,7 +23,6 @@ testcases/Repair.lhs testcases/blockcomment.hs testcases/constructor.hs - testcases/firstconstructor.hs testcases/module.hs testcases/space.hs testcases/substring.hs @@ -43,6 +42,10 @@ testcases/testcase11.hs testcases/simple.hs testcases/monad-base-control.hs + testcases/16.hs + testcases/16-regression.hs + testcases/9.hs + testcases/9-too.hs Flag debug Default: False @@ -64,7 +67,8 @@ bytestring >= 0.9 && < 0.11, directory >= 1.2.6 && < 1.4, filepath, - json >= 0.5 && < 0.10 + json >= 0.5 && < 0.10, + microlens-platform >= 0.3.8.0 && < 0.4 Executable hasktags Main-Is: src/Main.hs @@ -90,7 +94,8 @@ directory, filepath, json, - HUnit + HUnit, + microlens-platform other-modules: Tags, Hasktags, DebugShow ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Hasktags.hs b/src/Hasktags.hs --- a/src/Hasktags.hs +++ b/src/Hasktags.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- should this be named Data.Hasktags or such? module Hasktags ( FileData, @@ -13,40 +14,33 @@ dirToFiles ) where -import Tags - ( FileData(..), - FoundThing(..), - FoundThingType(FTConsAccessor, FTFuncTypeDef, FTClass, FTType, - FTCons, FTNewtype, FTData, FTDataGADT, FTModule, FTFuncImpl), - Pos(..), - FileName, - mywords, - writectagsfile, - writeetagsfile ) -import qualified Data.ByteString.Char8 as BS - ( ByteString, unpack, readFile ) -import qualified Data.ByteString.UTF8 as BS8 ( fromString ) -import Data.Char ( isSpace ) -import Data.List ( tails, nubBy, isSuffixOf, isPrefixOf ) -import Data.Maybe ( maybeToList ) -import System.IO - ( IOMode(WriteMode, AppendMode), - Handle, - hGetContents, - stdout, - stdin, - openFile, - hClose ) -import System.Directory - ( getModificationTime, - getDirectoryContents, - doesFileExist, - doesDirectoryExist, - isSymbolicLink ) -import Text.JSON.Generic ( encodeJSON, decodeJSON ) -import Control.Monad ( when ) -import DebugShow ( trace_ ) -import System.FilePath ( () ) +import Control.Monad (when) +import qualified Data.ByteString.Lazy.Char8 as BS (ByteString, readFile, unpack) +import qualified Data.ByteString.Lazy.UTF8 as BS8 (fromString) +import Data.Char (isSpace) +import Data.List (isPrefixOf, isSuffixOf, nubBy, + tails) +import Data.Maybe (maybeToList) +import DebugShow (trace_) +import System.Directory (doesDirectoryExist, doesFileExist, + getDirectoryContents, + getModificationTime, +#if MIN_VERSION_directory(1,3,0) + pathIsSymbolicLink) +#else + isSymbolicLink) +#endif +import System.FilePath (()) +import System.IO (Handle, + IOMode (AppendMode, WriteMode), + hClose, hGetContents, openFile, + stdin, stdout) +import Tags (FileData (..), FileName, + FoundThing (..), + FoundThingType (FTClass, FTCons, FTConsAccessor, FTConsGADT, FTData, FTDataGADT, FTFuncImpl, FTFuncTypeDef, FTInstance, FTModule, FTNewtype, FTPattern, FTPatternTypeDef, FTType), + Pos (..), Scope, mywords, + writectagsfile, writeetagsfile) +import Text.JSON.Generic (decodeJSON, encodeJSON) -- search for definitions of things -- we do this by looking for the following patterns: @@ -117,7 +111,6 @@ openMode data Mode = ExtendedCtag - | IgnoreCloseImpl | ETags | CTags | BothTags @@ -136,16 +129,16 @@ instance Show Token where -- show (Token t (Pos _ l _ _) ) = "Token " ++ t ++ " " ++ (show l) show (Token t (Pos _ _l _ _) ) = " " ++ t ++ " " - show (NewLine i) = "NewLine " ++ show i + show (NewLine i) = "NewLine " ++ show i tokenString :: Token -> String tokenString (Token s _) = s tokenString (NewLine _) = "\n" isNewLine :: Maybe Int -> Token -> Bool -isNewLine Nothing (NewLine _) = True +isNewLine Nothing (NewLine _) = True isNewLine (Just c) (NewLine c') = c == c' -isNewLine _ _ = False +isNewLine _ _ = False trimNewlines :: [Token] -> [Token] trimNewlines = filter (not . isNewLine Nothing) @@ -157,9 +150,7 @@ openFileMode = if Append `elem` modes then AppendMode else WriteMode - filedata <- mapM (findWithCache (CacheFiles `elem` modes) - (IgnoreCloseImpl `elem` modes)) - filenames + filedata <- mapM (findWithCache (CacheFiles `elem` modes)) filenames when (mode == CTags) (do ctagsfile <- getOutFile "tags" openFileMode modes @@ -183,8 +174,8 @@ -- Find the definitions in a file, or load from cache if the file -- hasn't changed since last time. -findWithCache :: Bool -> Bool -> FileName -> IO FileData -findWithCache cache ignoreCloseImpl filename = do +findWithCache :: Bool -> FileName -> IO FileData +findWithCache cache filename = do cacheExists <- if cache then doesFileExist cacheFilename else return False if cacheExists then do fileModified <- getModificationTime filename @@ -198,7 +189,7 @@ where cacheFilename = filenameToTagsName filename filenameToTagsName = (++"tags") . reverse . dropWhile (/='.') . reverse findAndCache = do - filedata <- findThings ignoreCloseImpl filename + filedata <- findThings filename when cache (writeFile cacheFilename (encodeJSON filedata)) return filedata @@ -211,19 +202,19 @@ utf8_to_char8_hack = BS.unpack . BS8.fromString -- Find the definitions in a file -findThings :: Bool -> FileName -> IO FileData -findThings ignoreCloseImpl filename = - fmap (findThingsInBS ignoreCloseImpl filename) $ BS.readFile filename +findThings :: FileName -> IO FileData +findThings filename = + fmap (findThingsInBS filename) $ BS.readFile filename -findThingsInBS :: Bool -> String -> BS.ByteString -> FileData -findThingsInBS ignoreCloseImpl filename bs = do +findThingsInBS :: String -> BS.ByteString -> FileData +findThingsInBS filename bs = do let aslines = lines $ BS.unpack bs let stripNonHaskellLines = let emptyLine = all (all isSpace . tokenString) . filter (not . isNewLine Nothing) cppLine (_nl:t:_) = ("#" `isPrefixOf`) $ tokenString t - cppLine _ = False + cppLine _ = False in filter (not . emptyLine) . filter (not . cppLine) let debugStep m = (\s -> trace_ (m ++ " result") s s) @@ -274,17 +265,21 @@ (FoundThing t2 n2 (Pos f2 _ _ _)) -> f1 == f2 && n1 == n2 - && t1 == FTFuncImpl - && t2 == FTFuncImpl ) + && areFuncImplsOfSameScope t1 t2) + areFuncImplsOfSameScope (FTFuncImpl a) (FTFuncImpl b) = a == b + areFuncImplsOfSameScope _ _ = False - let iCI = if ignoreCloseImpl - then nubBy (\(FoundThing _ n1 (Pos f1 l1 _ _)) - (FoundThing _ n2 (Pos f2 l2 _ _)) + let iCI = nubBy (\(FoundThing t1 n1 (Pos f1 l1 _ _)) + (FoundThing t2 n2 (Pos f2 l2 _ _)) -> f1 == f2 && n1 == n2 + && skipCons t1 t2 && ((<= 7) $ abs $ l2 - l1)) - else id - let things = iCI $ filterAdjacentFuncImpl $ concatMap findstuff $ map (\s -> trace_ "section in findThingsInBS" s s) sections + skipCons FTData (FTCons _ _) = False + skipCons FTDataGADT (FTConsGADT _) = False + skipCons _ _ = True + let things = iCI $ filterAdjacentFuncImpl $ concatMap (flip findstuff Nothing) $ + map (\s -> trace_ "section in findThingsInBS" s s) sections let -- If there's a module with the same name of another definition, we -- are not interested in the module, but only in the definition. @@ -300,17 +295,17 @@ withline :: FileName -> [String] -> String -> Int -> [Token] withline filename sourceWords fullline i = - let countSpaces (' ':xs) = 1 + countSpaces xs + let countSpaces (' ':xs) = 1 + countSpaces xs countSpaces ('\t':xs) = 8 + countSpaces xs - countSpaces _ = 0 + countSpaces _ = 0 in NewLine (countSpaces fullline) : zipWith (\w t -> Token w (Pos filename i t fullline)) sourceWords [1 ..] -- comments stripping stripslcomments :: [[Token]] -> [[Token]] -stripslcomments = let f (NewLine _ : Token "--" _ : _) = False - f _ = True +stripslcomments = let f (NewLine _ : Token ('-':'-':_) _ : _) = False + f _ = True in filter f stripblockcomments :: [Token] -> [Token] @@ -337,32 +332,37 @@ -- actually pick up definitions -findstuff :: [Token] -> [FoundThing] -findstuff (Token "module" _ : Token name pos : _) = +findstuff :: [Token] -> Scope -> [FoundThing] +findstuff (Token "module" _ : Token name pos : _) _ = trace_ "module" pos $ [FoundThing FTModule name pos] -- nothing will follow this section -findstuff tokens@(Token "data" _ : Token name pos : xs) +findstuff tokens@(Token "data" _ : Token name pos : xs) _ | any ( (== "where"). tokenString ) xs -- GADT -- TODO will be found as FTCons (not FTConsGADT), the same for -- functions - but they are found :) = trace_ "findstuff data b1" tokens $ FoundThing FTDataGADT name pos - : getcons2 xs ++ fromWhereOn xs -- ++ (findstuff xs) + : getcons2 (FTConsGADT name) "" xs ++ fromWhereOn xs Nothing -- ++ (findstuff xs) | otherwise = trace_ "findstuff data otherwise" tokens $ FoundThing FTData name pos - : getcons FTData (trimNewlines xs)-- ++ (findstuff xs) -findstuff tokens@(Token "newtype" _ : ts@(Token name pos : _)) = + : getcons (FTCons FTData name) (trimNewlines xs)-- ++ (findstuff xs) +findstuff tokens@(Token "newtype" _ : ts@(Token name pos : _))_ = trace_ "findstuff newtype" tokens $ FoundThing FTNewtype name pos - : getcons FTCons (trimNewlines ts)-- ++ (findstuff xs) + : getcons (FTCons FTNewtype name) (trimNewlines ts)-- ++ (findstuff xs) -- FoundThing FTNewtype name pos : findstuff xs -findstuff tokens@(Token "type" _ : Token name pos : xs) = +findstuff tokens@(Token "type" _ : Token name pos : xs) _ = trace_ "findstuff type" tokens $ - FoundThing FTType name pos : findstuff xs -findstuff tokens@(Token "class" _ : xs) = + case (break ((== "where").tokenString) xs) of + (ys, []) -> + trace_ "findstuff type b1 " ys $ [FoundThing FTType name pos] + (ys, r) -> + trace_ "findstuff type b2 " (ys, r) $ + FoundThing FTType name pos : fromWhereOn r Nothing +findstuff tokens@(Token "class" _ : xs) _ = trace_ "findstuff class" tokens $ case (break ((== "where").tokenString) xs) of (ys, []) -> @@ -370,87 +370,115 @@ maybeToList $ className ys (ys, r) -> trace_ "findstuff class b2 " (ys, r) $ - (maybeToList $ className ys) - ++ (maybe [] (:fromWhereOn r) $ className xs) + maybe [] (\n@(FoundThing _ name _) -> n : fromWhereOn r (Just (FTClass, name))) $ + className ys where isParenOpen (Token "(" _) = True - isParenOpen _ = False + isParenOpen _ = False className lst - = case (head + = case (head' . dropWhile isParenOpen . reverse . takeWhile ((not . (`elem` ["=>", utf8_to_char8_hack "⇒"])) . tokenString) . reverse) lst of - (Token name p) -> Just $ FoundThing FTClass name p - _ -> Nothing -findstuff xs = + (Just (Token name p)) -> Just $ FoundThing FTClass name p + _ -> Nothing +findstuff tokens@(Token "instance" _ : xs) _ = + trace_ "findstuff instance" tokens $ + case (break ((== "where").tokenString) xs) of + (ys, []) -> + trace_ "findstuff instance b1 " ys $ + maybeToList $ instanceName ys + (ys, r) -> + trace_ "findstuff instance b2 " (ys, r) $ + maybe [] (\n@(FoundThing _ name _) -> n : fromWhereOn r (Just (FTInstance, name))) $ + instanceName ys + where instanceName lst@(Token _ p :_) = Just $ FoundThing FTInstance + (map (\a -> if a == '.' then '-' else a) $ concatTokens lst) p + instanceName _ = Nothing +findstuff tokens@(Token "pattern" _ : Token name pos : Token "::" _ : sig) _ = + trace_ "findstuff pattern type annotation" tokens $ + [FoundThing (FTPatternTypeDef (concatTokens sig)) name pos] +findstuff tokens@(Token "pattern" _ : Token name pos : xs) scope = + trace_ "findstuff pattern" tokens $ + FoundThing FTPattern name pos : findstuff xs scope +findstuff xs scope = trace_ "findstuff rest " xs $ - findFunc xs ++ findFuncTypeDefs [] xs + findFunc xs scope ++ findFuncTypeDefs [] xs scope -findFuncTypeDefs :: [Token] -> [Token] -> [FoundThing] -findFuncTypeDefs found (t@(Token _ _): Token "," _ :xs) = - findFuncTypeDefs (t : found) xs -findFuncTypeDefs found (t@(Token _ _): Token "::" _ :_) = - map (\(Token name p) -> FoundThing FTFuncTypeDef name p) (t:found) -findFuncTypeDefs found (Token "(" _ :xs) = +findFuncTypeDefs :: [Token] -> [Token] -> Scope -> [FoundThing] +findFuncTypeDefs found (t@(Token _ _): Token "," _ :xs) scope = + findFuncTypeDefs (t : found) xs scope +findFuncTypeDefs found (t@(Token _ _): Token "::" _ : sig) scope = + map (\(Token name p) -> FoundThing (FTFuncTypeDef (concatTokens sig) scope) name p) (t:found) +findFuncTypeDefs found xs@(Token "(" _ :_) scope = case break myBreakF xs of - (inner@(Token _ p : _), _:xs') -> - let merged = Token ( concatMap (\(Token x _) -> x) inner ) p - in findFuncTypeDefs found $ merged : xs' + (inner@(Token _ p : _), rp : xs') -> + let merged = Token ( concatMap (\(Token x _) -> x) $ inner ++ [rp] ) p + in findFuncTypeDefs found (merged : xs') scope _ -> [] where myBreakF (Token ")" _) = True - myBreakF _ = False -findFuncTypeDefs _ _ = [] + myBreakF _ = False +findFuncTypeDefs _ _ _ = [] -fromWhereOn :: [Token] -> [FoundThing] -fromWhereOn [] = [] -fromWhereOn [_] = [] -fromWhereOn (_: xs@(NewLine _ : _)) = - concatMap (findstuff . tail') +fromWhereOn :: [Token] -> Scope -> [FoundThing] +fromWhereOn [] _ = [] +fromWhereOn [_] _ = [] +fromWhereOn (_: xs@(NewLine _ : _)) scope = + concatMap (flip findstuff scope . tail') $ splitByNL (Just ( minimum . (10000:) . map (\(NewLine i) -> i) . filter (isNewLine Nothing) $ xs)) xs -fromWhereOn (_:xw) = findstuff xw +fromWhereOn (_:xw) scope = findstuff xw scope -findFunc :: [Token] -> [FoundThing] -findFunc x = case findInfix x of +findFunc :: [Token] -> Scope -> [FoundThing] +findFunc x scope = case findInfix x scope of a@(_:_) -> a - _ -> findF x + _ -> findF x scope -findInfix :: [Token] -> [FoundThing] -findInfix x +findInfix :: [Token] -> Scope -> [FoundThing] +findInfix x scope = case dropWhile ((/= "`"). tokenString) (takeWhile ( (/= "=") . tokenString) x) of - _ : Token name p : _ -> [FoundThing FTFuncImpl name p] - _ -> [] + _ : Token name p : _ -> [FoundThing (FTFuncImpl scope) name p] + _ -> [] -findF :: [Token] -> [FoundThing] -findF (Token name p : xs) = - [FoundThing FTFuncImpl name p | any (("=" ==) . tokenString) xs] -findF _ = [] +findF :: [Token] -> Scope -> [FoundThing] +findF ts@(Token "(" p : _) scope = + let (name, xs) = extractOperator ts in + [FoundThing (FTFuncImpl scope) name p | any (("=" ==) . tokenString) xs] +findF (Token name p : xs) scope = + [FoundThing (FTFuncImpl scope) name p | any (("=" ==) . tokenString) xs] +findF _ _ = [] +head' :: [a] -> Maybe a +head' (x:_) = Just x +head' [] = Nothing + tail' :: [a] -> [a] tail' (_:xs) = xs -tail' [] = [] +tail' [] = [] -- get the constructor definitions, knowing that a datatype has just started getcons :: FoundThingType -> [Token] -> [FoundThing] getcons ftt (Token "=" _: Token name pos : xs) = - FoundThing ftt name pos : getcons2 xs + FoundThing ftt name pos : getcons2 ftt name xs getcons ftt (_:xs) = getcons ftt xs getcons _ [] = [] -getcons2 :: [Token] -> [FoundThing] -getcons2 (Token name pos : Token "::" _ : xs) = - FoundThing FTConsAccessor name pos : getcons2 xs -getcons2 (Token "|" _ : Token name pos : xs) = - FoundThing FTCons name pos : getcons2 xs -getcons2 (_:xs) = getcons2 xs -getcons2 [] = [] +getcons2 :: FoundThingType -> String -> [Token] -> [FoundThing] +getcons2 ftt@(FTCons pt p) c (Token name pos : Token "::" _ : xs) = + FoundThing (FTConsAccessor pt p c) name pos : getcons2 ftt c xs +getcons2 ftt@(FTConsGADT p) _ (Token name pos : Token "::" _ : xs) = + FoundThing ftt name pos : getcons2 ftt p xs +getcons2 ftt _ (Token "|" _ : Token name pos : xs) = + FoundThing ftt name pos : getcons2 ftt name xs +getcons2 ftt c (_:xs) = getcons2 ftt c xs +getcons2 _ _ [] = [] splitByNL :: Maybe Int -> [Token] -> [[Token]] @@ -498,7 +526,11 @@ dirToFiles _ _ "STDIN" = fmap lines $ hGetContents stdin dirToFiles followSyms suffixes p = do isD <- doesDirectoryExist p +#if MIN_VERSION_directory(1,3,0) + isSymLink <- pathIsSymbolicLink p +#else isSymLink <- isSymbolicLink p +#endif case isD of False -> return $ if matchingSuffix then [p] else [] True -> @@ -509,3 +541,28 @@ contents <- filter ((/=) '.' . head) `fmap` getDirectoryContents p concat `fmap` (mapM (dirToFiles followSyms suffixes . () p) contents) where matchingSuffix = any (`isSuffixOf` p) suffixes + +concatTokens :: [Token] -> String +concatTokens = smartUnwords . map (\(Token name _) -> name) . + filter (not . isNewLine Nothing) . stripilcomments + where smartUnwords [] = [] + smartUnwords a = foldr (\v -> (glueNext v ++)) "" $ a `zip` tail (a ++ [""]) + glueNext (a@("("), _) = a + glueNext (a, ")") = a + glueNext (a@("["), _) = a + glueNext (a, "]") = a + glueNext (a, ",") = a + glueNext (a, "") = a + glueNext (a, _) = a ++ " " + stripilcomments = fst . + foldl (\(a, c) v -> case v of + Token ('-':'-':_) _ -> (a, True) + NewLine _ -> (a ++ [v], False) + _ -> if c then (a, c) else (a ++ [v], c) + ) ([], False) + +extractOperator :: [Token] -> (String, [Token]) +extractOperator ts@(Token "(" _ : _) = + (\(a, b) -> (foldr ((++) . tokenString) ")" a, tail' b)) $ + break ((== ")") . tokenString) ts +extractOperator _ = ("", []) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,16 +1,16 @@ {-# LANGUAGE CPP #-} module Main (main) where -import Hasktags +import Hasktags -import System.Environment +import System.Environment -import Data.List +import Data.List -import System.Directory -import System.Console.GetOpt -import System.Exit -import Control.Monad +import Control.Monad +import System.Console.GetOpt +import System.Directory +import System.Exit hsSuffixesDefault :: Mode hsSuffixesDefault = HsSuffixes [ ".hs", ".lhs", ".hsc" ] @@ -26,10 +26,6 @@ (NoArg Append) $ "append to existing CTAGS and/or ETAGS file(s). Afterward this " ++ "file will no longer be sorted!" - , Option "" ["ignore-close-implementation"] - (NoArg IgnoreCloseImpl) - $ "ignores found implementation if it is 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" @@ -44,11 +40,11 @@ , Option "R" ["tags-absolute"] (NoArg AbsolutePath) "make tags paths absolute. Useful when setting tags files in other directories" , Option "h" ["help"] (NoArg Help) "This help" ] - where suffStr Nothing = hsSuffixesDefault + where suffStr Nothing = hsSuffixesDefault suffStr (Just s) = HsSuffixes $ strToSuffixes s strToSuffixes = lines . map commaToEOL commaToEOL ',' = '\n' - commaToEOL x = x + commaToEOL x = x main :: IO () diff --git a/src/Tags.hs b/src/Tags.hs --- a/src/Tags.hs +++ b/src/Tags.hs @@ -1,13 +1,16 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} -- everyting tagfile related .. -- this should be moved into its own library (after cleaning up most of it ..) -- yes, this is still specific to hasktags :( module Tags where -import Data.Char ( isSpace ) -import Data.List ( sortBy ) -import Data.Data ( Data, Typeable ) -import System.IO ( Handle, hPutStrLn, hPutStr ) -import Control.Monad ( when ) +import Control.Monad (when) +import Data.Char (isSpace) +import Data.Data (Data, Typeable) +import Data.List (sortBy) +import Data.List (intercalate) +import Lens.Micro.Platform +import System.IO (Handle, hPutStr, hPutStrLn) -- my words is mainly copied from Data.List. -- difference abc::def is recognized as three words @@ -49,44 +52,62 @@ type ThingName = String +type Scope = Maybe (FoundThingType, 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 +data Pos = Pos { _fileName :: FileName -- file name + , _lineNumber :: Int -- line number + , _tokenNumber :: Int -- token number + , _lineContent :: String -- string that makes up that line + } deriving (Show,Eq,Typeable,Data) -- A definition we have found -- I'm not sure wether I've used the right names.. but I hope you fix it / get -- what I mean data FoundThingType - = FTFuncTypeDef - | FTFuncImpl + = FTFuncTypeDef String Scope + | FTFuncImpl Scope | FTType | FTData | FTDataGADT | FTNewtype | FTClass + | FTInstance | FTModule - | FTCons + | FTCons FoundThingType String | FTOther - | FTConsAccessor - | FTConsGADT + | FTConsAccessor FoundThingType String String + | FTConsGADT String + | FTPatternTypeDef String + | FTPattern deriving (Eq,Typeable,Data) instance Show FoundThingType where - show FTFuncTypeDef = "ft" - show FTFuncImpl = "fi" + show (FTFuncTypeDef s (Just (FTClass, p))) = + "ft\t" ++ "signature:(" ++ s ++ ")\t" ++ "class:" ++ p + show (FTFuncTypeDef s (Just (FTInstance, p))) = + "ft\t" ++ "signature:(" ++ s ++ ")\t" ++ "instance:" ++ p + show (FTFuncTypeDef s _) = "ft\t" ++ "signature:(" ++ s ++ ")" + show (FTFuncImpl (Just (FTClass, p)))= "fi\t" ++ "class:" ++ p + show (FTFuncImpl (Just (FTInstance, p)))= "fi\t" ++ "instance:" ++ p + show (FTFuncImpl _)= "fi" show FTType = "t" show FTData = "d" show FTDataGADT = "d_gadt" show FTNewtype = "nt" show FTClass = "c" + show FTInstance = "i" show FTModule = "m" - show FTCons = "cons" - show FTConsGADT = "c_gadt" - show FTConsAccessor = "c_a" + show (FTCons FTData p) = "cons\t" ++ "data:" ++ p + show (FTCons FTNewtype p) = "cons\t" ++ "newtype:" ++ p + show FTCons {} = "cons" + show (FTConsGADT p) = "c_gadt\t" ++ "d_gadt:" ++ p + show (FTConsAccessor FTData p c) = "c_a\t" ++ "cons:" ++ p ++ "." ++ c + show (FTConsAccessor FTNewtype p c) = "c_a\t" ++ "cons:" ++ p ++ "." ++ c + show FTConsAccessor {} = "c_a" + show (FTPatternTypeDef s) = "pt\t" ++ "signature:(" ++ s ++ ")" + show FTPattern = "pi" show FTOther = "o" data FoundThing = FoundThing FoundThingType ThingName Pos @@ -96,26 +117,35 @@ data FileData = FileData FileName [FoundThing] deriving (Typeable,Data,Show) +makeLenses ''Pos + getfoundthings :: FileData -> [FoundThing] getfoundthings (FileData _ things) = things ctagEncode :: Char -> String -ctagEncode '/' = "\\/" +ctagEncode '/' = "\\/" ctagEncode '\\' = "\\\\" -ctagEncode a = [a] +ctagEncode a = [a] + +showLine :: Pos -> String +showLine = show . view lineNumber . over lineNumber (+1) + +normalDump :: FoundThing -> String +normalDump (FoundThing _ n p) = intercalate "\t" [n, p^.fileName, showLine p] + +extendedDump :: FoundThing -> String +extendedDump (FoundThing t n p) = intercalate "\t" [n, p^.fileName, content, kindInfo, lineInfo, "language:Haskell"] + where content = "/^" ++ concatMap ctagEncode (p^.lineContent) ++ "$/;\"" + kindInfo = show t + lineInfo = "line:" ++ showLine p + -- | Dump found tag in normal or extended (read : vim like) ctag -- line -dumpthing :: Bool -> FoundThing -> String -dumpthing False (FoundThing _ name (Pos filename line _ _)) = - name ++ "\t" ++ filename ++ "\t" ++ show (line + 1) -dumpthing True (FoundThing kind name (Pos filename line _ lineText)) = - name ++ "\t" ++ filename - ++ "\t/^" ++ concatMap ctagEncode lineText - ++ "$/;\"\t" ++ show kind - ++ "\tline:" ++ show (line + 1) - ++ "\tlanguage:Haskell" - +dumpThing :: Bool -> FoundThing -> String +dumpThing cond thing = if cond + then extendedDump thing + else normalDump thing -- stuff for dealing with ctags output format writectagsfile :: Handle -> Bool -> [FileData] -> IO () @@ -130,7 +160,7 @@ ctagsfile "!_TAG_FILE_SORTED\t1\t/0=unsorted, 1=sorted, 2=foldcase/" hPutStrLn ctagsfile "!_TAG_PROGRAM_NAME\thasktags") - mapM_ (hPutStrLn ctagsfile . dumpthing extended) (sortThings things) + mapM_ (hPutStrLn ctagsfile . dumpThing extended) (sortThings things) sortThings :: [FoundThing] -> [FoundThing] sortThings = sortBy comp @@ -152,9 +182,6 @@ thingslength = length thingsdump etagsDumpThing :: FoundThing -> String -etagsDumpThing (FoundThing _ name (Pos _filename line token fullline)) = - let wrds = mywords True fullline - in concat (take token wrds ++ map (take 1) (take 1 $ drop token wrds)) - ++ "\x7f" - ++ name ++ "\x01" - ++ show line ++ "," ++ show (line + 1) ++ "\n" +etagsDumpThing (FoundThing _ name pos) = + let line = pos^.lineNumber + in concat [name, "\x7f", name, "\x01", show line, ",", show (line + 1), "\n"] diff --git a/testcases/16-regression.hs b/testcases/16-regression.hs new file mode 100644 --- /dev/null +++ b/testcases/16-regression.hs @@ -0,0 +1,14 @@ +-- to be found T +-- to be found T +-- to be found t1 +-- to be found t2 +-- to be found t3 +-- to be found t4 +-- to be found t5 +data T = T { + t1 :: Int + , t2 :: Int + , t3 :: Int + , t4 :: Int + , t5 :: Int +} diff --git a/testcases/16.hs b/testcases/16.hs new file mode 100644 --- /dev/null +++ b/testcases/16.hs @@ -0,0 +1,14 @@ +-- to be found T +-- to be found T +-- to be found t1 +-- to be found t2 +-- to be found t3 +-- to be found t4 +-- to be found t5 +data T = T { + t1 :: Int +, t2 :: Int +, t3 :: Int +, t4 :: Int +, t5 :: Int +} diff --git a/testcases/9-too.hs b/testcases/9-too.hs new file mode 100644 --- /dev/null +++ b/testcases/9-too.hs @@ -0,0 +1,8 @@ +-- to be found (-:>) +-- to be found (-+>) + +(-:>) :: a -> b -> c +k -:> f = undefined + +(-+>) :: a -> b -> c +k -+> f = undefined diff --git a/testcases/9.hs b/testcases/9.hs new file mode 100644 --- /dev/null +++ b/testcases/9.hs @@ -0,0 +1,5 @@ +-- to be found (-:) +-- to be found (->>) + +(-:) = undefined +(->>) = undefined diff --git a/testcases/HUnitBase.lhs b/testcases/HUnitBase.lhs --- a/testcases/HUnitBase.lhs +++ b/testcases/HUnitBase.lhs @@ -3,16 +3,16 @@ -- to be found assertEqual -- to be found ListAssertable -- to be found AssertionPredicable --- to be found @? --- to be found @=? --- to be found @?= +-- to be found (@?) +-- to be found (@=?) +-- to be found (@?=) -- to be found Path -- to be found testCaseCount -- to be found Testable --- to be found ~? --- to be found ~=? --- to be found ~?= --- to be found ~: +-- to be found (~?) +-- to be found (~=?) +-- to be found (~?=) +-- to be found (~:) -- to be found State -- to be found ReportProblem -- to be found testCasePaths diff --git a/testcases/firstconstructor.hs b/testcases/firstconstructor.hs deleted file mode 100644 --- a/testcases/firstconstructor.hs +++ /dev/null @@ -1,2 +0,0 @@ --- TAGS to be found data A = C -data A = C diff --git a/testcases/testcase1.hs b/testcases/testcase1.hs --- a/testcases/testcase1.hs +++ b/testcases/testcase1.hs @@ -57,7 +57,7 @@ -- TODO - -- to be found =~ + -- to be found (=~) (=~) :: (Regex rho) => String -> rho -> Bool diff --git a/testcases/testcase8.hs b/testcases/testcase8.hs --- a/testcases/testcase8.hs +++ b/testcases/testcase8.hs @@ -1,8 +1,8 @@ -- to be found Main -- to be found ABC -- to be found ABCD --- to be found @=? --- to be found @=: +-- to be found (@=?) +-- to be found (@=:) -- to be found dummy -- to be found main module Main where diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,16 +1,16 @@ module Main where -import Hasktags -import Tags +import Hasktags +import Tags -import Control.Monad -import Data.List -import System.Directory -import System.Exit +import Control.Monad +import Data.List +import System.Directory +import System.Exit -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BS -import Test.HUnit +import Test.HUnit {- TODO Test the library (recursive, caching, ..) @@ -72,7 +72,7 @@ createTestCase filename = do bs <- BS.readFile filename let lns = BS.lines bs - let fd = findThingsInBS True filename bs + let fd = findThingsInBS filename bs let FileData _ things = fd let foundTagNames = [name | FoundThing _ name _ <- things]