packages feed

hasktags 0.69.5 → 0.70.0

raw patch · 14 files changed

+347/−199 lines, 14 filesdep +microlens-platformPVP ok

version bump matches the API change (PVP)

Dependencies added: microlens-platform

API changes (from Hackage documentation)

- Hasktags: IgnoreCloseImpl :: Mode
- Hasktags: findThings :: Bool -> FileName -> IO FileData
+ Hasktags: findThings :: FileName -> IO FileData
- Hasktags: findThingsInBS :: Bool -> String -> ByteString -> FileData
+ Hasktags: findThingsInBS :: String -> ByteString -> FileData
- Hasktags: findWithCache :: Bool -> Bool -> FileName -> IO FileData
+ Hasktags: findWithCache :: Bool -> FileName -> IO FileData

Files

README.md view
@@ -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<tab>` 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/
hasktags.cabal view
@@ -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
src/Hasktags.hs view
@@ -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 _ = ("", [])
src/Main.hs view
@@ -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 ()
src/Tags.hs view
@@ -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"]
+ testcases/16-regression.hs view
@@ -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+}
+ testcases/16.hs view
@@ -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+}
+ testcases/9-too.hs view
@@ -0,0 +1,8 @@+-- to be found (-:>)+-- to be found (-+>)++(-:>) :: a -> b -> c+k -:> f = undefined++(-+>) :: a -> b -> c+k -+> f = undefined
+ testcases/9.hs view
@@ -0,0 +1,5 @@+-- to be found (-:)+-- to be found (->>)++(-:) = undefined+(->>) = undefined
testcases/HUnitBase.lhs view
@@ -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
− testcases/firstconstructor.hs 
@@ -1,2 +0,0 @@--- TAGS to be found data A = C-data A = C
testcases/testcase1.hs view
@@ -57,7 +57,7 @@  -- TODO  -    -- to be found =~+    -- to be found (=~)     (=~)   :: (Regex rho) => String -> rho -> Bool
testcases/testcase8.hs view
@@ -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
tests/Test.hs view
@@ -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]