fast-tags 0.0.4 → 0.0.5
raw patch · 4 files changed
+271/−39 lines, 4 files
Files
- fast-tags.cabal +9/−3
- src/Main.hs +58/−24
- src/Main_test.hs +30/−12
- src/mt.hs +174/−0
fast-tags.cabal view
@@ -1,5 +1,5 @@ name: fast-tags-version: 0.0.4+version: 0.0.5 cabal-version: >= 1.8 build-type: Simple synopsis: Fast incremental vi tags.@@ -11,11 +11,17 @@ In addition, it will load an existing tags file and merge generated tags. . The intent is to bind it to vim's BufWrite autocommand to automatically- keep the tags file up to date.+ keep the tags file up to date. This only works for files changed be the+ editor of course, so you may want to bind 'rm tags' to a 'pull' posthook. .+ Changes since 0.0.4:+ .+ * Tags with the same name are sorted by their type: Function, Type,+ Constructor, Class, Module.+ . Changes since 0.0.3: .- * Fixed bug that prevented old tags from being filered out.+ * Fixed bug that prevented old tags from being filtered out. . Changes since 0.0.2: .
src/Main.hs view
@@ -39,19 +39,25 @@ verbose = Verbose `elem` flags oldTags <- fmap (maybe [vimMagicLine] T.lines) $ catchENOENT $ Text.IO.readFile output- newTags <- fmap concat $ forM (zip [0..] inputs) $ \(i :: Int, fn) -> do- tags <- processFile fn- -- This has the side-effect of forcing the the tags, which is essential- -- if I'm tagging a lot of files at once.- let (warnings, newTags) = Either.partitionEithers tags- forM_ warnings $ \warn -> do- IO.hPutStrLn IO.stderr warn- when verbose $ do- let line = show i ++ " of " ++ show (length inputs - 1)- ++ ": " ++ fn- putStr $ '\r' : line ++ replicate (78 - length line) ' '- IO.hFlush IO.stdout- return newTags+ -- This will merge and sort the new tags. But I don't run it on the+ -- the result of merging the old and new tags, so tags from another+ -- file won't be sorted properly. To do that I'd have to parse all the+ -- old tags and run processAll on all of them, which is a hassle.+ -- TODO try it and see if it really hurts performance that much.+ newTags <- fmap (processAll . concat) $+ forM (zip [0..] inputs) $ \(i :: Int, fn) -> do+ tags <- processFile fn+ -- This has the side-effect of forcing the the tags, which is+ -- essential if I'm tagging a lot of files at once.+ let (warnings, newTags) = Either.partitionEithers tags+ forM_ warnings $ \warn -> do+ IO.hPutStrLn IO.stderr warn+ when verbose $ do+ let line = show i ++ " of " ++ show (length inputs - 1)+ ++ ": " ++ fn+ putStr $ '\r' : line ++ replicate (78 - length line) ' '+ IO.hFlush IO.stdout+ return newTags when verbose $ putChar '\n' let write = if output == "-" then Text.IO.hPutStr IO.stdout@@ -63,11 +69,10 @@ mergeTags :: [FilePath] -> [Text] -> [Pos TagVal] -> [Text] mergeTags inputs old new =- merge (List.sort (map showTag new)) (filter (not . isNewTag textFns) old)- where- -- Turns out GHC will not float out the T.pack and it makes a big- -- performance difference.- textFns = Set.fromList $ map T.pack inputs+ -- 'new' was already been sorted by 'process', but then I just concat+ -- the tags from each file, so they need sorting again.+ merge (map showTag new) (filter (not . isNewTag textFns) old)+ where textFns = Set.fromList $ map T.pack inputs data Flag = Output FilePath | Verbose deriving (Eq, Show)@@ -152,13 +157,41 @@ data SrcPos = SrcPos { posFile :: !FilePath , posLine :: !Int- }+ } deriving (Eq) instance (Show a) => Show (Pos a) where show (Pos pos val) = show pos ++ ":" ++ show val instance Show SrcPos where show (SrcPos fn line) = fn ++ ":" ++ show line +-- * process++-- | Global processing for when all tags are together.+processAll :: [Pos TagVal] -> [Pos TagVal]+processAll = sortDups . dropDups (\t -> (posOf t, tagText t))+ . sortOn tagText++-- | Given multiple matches, vim will jump to the first one. So sort adjacent+-- tags with the same text by their type.+--+-- Mostly this is so that given a type with the same name as its module,+-- the type will come first.+sortDups :: [Pos TagVal] -> [Pos TagVal]+sortDups = concat . sort . List.groupBy (\a b -> tagText a == tagText b)+ where+ sort = map (sortOn key)+ key :: Pos TagVal -> Int+ key (Pos _ (Tag _ typ)) = case typ of+ Function -> 0+ Type -> 1+ Constructor -> 2+ Class -> 3+ Module -> 4++tagText :: Pos TagVal -> Text+tagText (Pos _ (Tag text _)) = text++-- | Read tags from one file. processFile :: FilePath -> IO [Tag] processFile fn = fmap (process fn) (Text.IO.readFile fn) `Exception.catch` \(exc :: Exception.SomeException) -> do@@ -168,12 +201,10 @@ ++ show exc return [] +-- | Process one file's worth of tags. process :: FilePath -> Text -> [Tag]-process fn = dropDups tagText . concatMap blockTags . breakBlocks- . stripComments . Monoid.mconcat . map tokenize . stripCpp . annotate fn- where- tagText (Right (Pos _ (Tag text _))) = text- tagText (Left warn) = T.pack warn+process fn = concatMap blockTags . breakBlocks . stripComments+ . Monoid.mconcat . map tokenize . stripCpp . annotate fn -- * tokenize @@ -461,3 +492,6 @@ | key a == key b = go a bs | otherwise = a : go b bs dropDups _ [] = []++sortOn :: (Ord k) => (a -> k) -> [a] -> [a]+sortOn key = List.sortBy (\a b -> compare (key a) (key b))
src/Main_test.hs view
@@ -2,8 +2,10 @@ module Main_test where import qualified Control.Exception as Exception import Control.Monad+import qualified Data.Either as Either import qualified Data.Monoid as Monoid import qualified Data.Text as Text+ import Exception (assert) import qualified System.IO.Unsafe as Unsafe @@ -12,11 +14,11 @@ -- This is kind of annoying without automatic test_* collection...-main = do- test_tokenize- test_skipString- test_stripComments- test_process+main = sequence_+ [ test_tokenize, test_skipString, test_stripComments+ , test_breakBlocks, test_processAll+ , test_process+ ] test_tokenize = do -- drop leading "nl 0"@@ -61,8 +63,25 @@ equal assert (f "1\n 11\n 11\n") [["1", "11", "11"]] equal assert (f " 11\n 11\n") [["11"], ["11"]] +test_processAll = do+ let f = map showTag . Main.processAll . Either.rights+ . concatMap (\(i, t) -> Main.process ("fn" ++ show i) t)+ . zip [0..]+ showTag (Pos p (Tag text typ)) =+ unwords [show p, Text.unpack text, show typ]+ equal assert (f ["data X", "module X"])+ ["fn0:1 X Type", "fn1:1 X Module"]+ -- Type goes ahead of Module.+ equal assert (f ["module X\ndata X"])+ ["fn0:2 X Type", "fn0:1 X Module"]+ -- Extra X was filtered.+ equal assert (f ["module X\ndata X = X\n"])+ ["fn0:2 X Type", "fn0:1 X Module"]+ test_process = sequence_- [test_misc, test_data, test_gadt, test_families, test_functions, test_class]+ [ test_misc, test_data, test_gadt, test_families, test_functions+ , test_class+ ] test_misc = do let f text = [tag | Right (Pos _ tag) <- Main.process "fn" text]@@ -81,19 +100,18 @@ test_data = do let f = process equal assert (f "data X\n") ["X"]- -- The extra X is suppressed.- equal assert (f "data X = X Int\n") ["X"]+ equal assert (f "data X = X Int\n") ["X", "X"] equal assert (f "data Foo = Bar | Baz") ["Foo", "Bar", "Baz"] equal assert (f "data Foo =\n\tBar\n\t| Baz") ["Foo", "Bar", "Baz"] -- Records. equal assert (f "data Foo a = Bar { field :: Field }") ["Foo", "Bar", "field"]- equal assert (f "data R = R { a::X, b::Y }") ["R", "a", "b"]- equal assert (f "data R = R {\n\ta::X\n\t, b::Y\n\t}") ["R", "a", "b"]- equal assert (f "data R = R {\n\ta,b::X\n\t}") ["R", "a", "b"]+ equal assert (f "data R = R { a::X, b::Y }") ["R", "R", "a", "b"]+ equal assert (f "data R = R {\n\ta::X\n\t, b::Y\n\t}") ["R", "R", "a", "b"]+ equal assert (f "data R = R {\n\ta,b::X\n\t}") ["R", "R", "a", "b"] equal assert (f "data R = R {\n\ta :: !RealTime\n\t, b :: !RealTime\n\t}")- ["R", "a", "b"]+ ["R", "R", "a", "b"] test_gadt = do let f = process
+ src/mt.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE OverloadedStrings #-}+module Main_test where+import qualified Control.Exception as Exception+import Control.Monad+import qualified Data.Monoid as Monoid+import qualified Data.Text as Text+import Exception (assert)+import qualified System.IO.Unsafe as Unsafe++import qualified Main as Main+import Main (TokenVal(..), TagVal(..), Type(..), Tag, Pos(..))+++-- This is kind of annoying without automatic test_* collection...+main = do+ test_tokenize+ test_skipString+ test_stripComments+ test_process++test_tokenize = do+ -- drop leading "nl 0"+ let f = drop 1 . extractTokens . tokenize+ equal assert (f "a::b->c") ["a", "::", "b", "->", "c"]+ equal assert (f "x{-\n bc#-}\n")+ ["x", "{-", "nl 2", "bc", "#", "-}"]+ equal assert (f "X.Y") ["X.Y"]+ equal assert (f "x9") ["x9"]+ -- equal assert (f "9x") ["nl 0", "9", "x"]+ equal assert (f "x :+: y") ["x", ":+:", "y"]+ equal assert (f "(#$)") ["(#$)"]+ equal assert (f "$#-- hi") ["$#", "--", "hi"]+ equal assert (f "(*), (-)") ["(*)", ",", "(-)"]++test_skipString = do+ let f = Main.skipString+ equal assert (f "hi \" there") " there"+ equal assert (f "hi \\a \" there") " there"+ equal assert (f "hi \\\" there\"") ""+ equal assert (f "hi") ""+ -- String continuation isn't implemented yet.+ equal assert (f "hi \\") ""++test_stripComments = do+ let f = extractTokens . Main.stripComments . tokenize+ equal assert (f "hello -- there") ["nl 0", "hello"]+ equal assert (f "hello {- there -} fred") ["nl 0", "hello", "fred"]+ equal assert (f "{-# LANG #-} hello {- there {- nested -} comment -} fred")+ ["nl 0", "hello", "fred"]++test_breakBlocks = do+ let f = map (extractTokens . Main.UnstrippedTokens . Main.stripNewlines)+ . Main.breakBlocks . tokenize+ equal assert (f "1\n2\n") [["1"], ["2"]]+ equal assert (f "1\n 1\n2\n") [["1", "1"], ["2"]]+ equal assert (f "1\n 1\n 1\n2\n") [["1", "1", "1"], ["2"]]+ -- intervening blank lines are ignored+ equal assert (f "1\n 1\n\n 1\n2\n") [["1", "1", "1"], ["2"]]+ equal assert (f "1\n\n\n 1\n2\n") [["1", "1"], ["2"]]++ equal assert (f "1\n 11\n 11\n") [["1", "11", "11"]]+ equal assert (f " 11\n 11\n") [["11"], ["11"]]++test_process = sequence_+ [ test_sort_dups, test_misc, test_data, test_gadt, test_families+ , test_functions, test_class+ ]++test_sort_dups = do+ let f text = [tag | Right (Pos _ tag) <- Main.process "fn" text]+ equal assert (f "module X where\ndata Y = X\ntype X\nclass X where\n")+ [ Tag "X" Type, Tag "X" Constructor, Tag "X" Class, Tag "X" Module+ , Tag "Y" Type+ ]++test_misc = do+ let f text = [tag | Right (Pos _ tag) <- Main.process "fn" text]+ equal assert (f "module Bar.Foo where\n") [Tag "Foo" Module]+ equal assert (f "newtype Foo a b =\n\tBar x y z\n")+ [Tag "Bar" Constructor, Tag "Foo" Type]+ equal assert (f "f :: A -> B\ng :: C -> D\ndata D = C {\n\tf :: A\n\t}\n")+ [Tag "C" Constructor, Tag "D" Type, Tag "f" Function,+ Tag "f" Function, Tag "g" Function]++test_unicode = do+ let f = process+ equal assert (f "數字 :: Int") ["數字"]+ equal assert (f "(·), x :: Int") ["·", "x"]++test_data = do+ let f = process+ equal assert (f "data X\n") ["X"]+ -- The extra X is suppressed.+ equal assert (f "data X = X Int\n") ["X"]+ equal assert (f "data Foo = Bar | Baz") ["Bar", "Baz", "Foo"]+ equal assert (f "data Foo =\n\tBar\n\t| Baz") ["Bar", "Baz", "Foo"]+ -- Records.+ equal assert (f "data Foo a = Bar { field :: Field }")+ ["Bar", "Foo", "field"]+ equal assert (f "data R = R { a::X, b::Y }") ["R", "a", "b"]+ equal assert (f "data R = R {\n\ta::X\n\t, b::Y\n\t}") ["R", "a", "b"]+ equal assert (f "data R = R {\n\ta,b::X\n\t}") ["R", "a", "b"]++ equal assert (f "data R = R {\n\ta :: !RealTime\n\t, b :: !RealTime\n\t}")+ ["R", "a", "b"]++test_gadt = do+ let f = process+ equal assert (f "data X where A :: X\n") ["A", "X"]+ equal assert (f "data X where\n\tA :: X\n") ["A", "X"]+ equal assert (f "data X where\n\tA :: X\n\tB :: X\n") ["A", "B", "X"]+ equal assert (f "data X where\n\tA, B :: X\n") ["A", "B", "X"]++test_families = do+ let f = process+ equal assert (f "type family X :: *\n") ["X"]+ equal assert (f "data family X :: * -> *\n") ["X"]+ equal assert (f "class C where\n\ttype X y :: *\n") ["C", "X"]+ equal assert (f "class C where\n\tdata X y :: *\n") ["C", "X"]++test_functions = do+ let f = process+ -- Multiple declarations.+ equal assert (f "a,b::X") ["a", "b"]+ -- With an operator.+ equal assert (f "(+), a :: X") ["+", "a"]+ -- Don't get fooled by literals.+ equal assert (f "1 :: Int") []++test_class = do+ let f = process+ equal assert (f "class (X x) => C a b where\n\tm :: a->b\n\tn :: c\n")+ ["C", "m", "n"]+ equal assert (f "class A a where f :: X\n") ["A", "f"]+ -- indented inside where+ equal assert (f "class X where\n\ta, (+) :: X\n") ["+", "X", "a"]+ equal assert (f "class X where\n\ta :: X\n\tb, c :: Y")+ ["X", "a", "b", "c"]+ equal assert (f "class X\n\twhere\n\ta :: X\n\tb, c :: Y")+ ["X", "a", "b", "c"]+ equal assert (f "class X\n\twhere\n\ta ::\n\t\tX\n\tb :: Y")+ ["X", "a", "b"]++process :: Text.Text -> [String]+process = map untag . Main.process "fn"++untag :: Tag -> String+untag (Right (Pos _ (Tag name _))) = Text.unpack name+untag (Left warn) = "warn: " ++ warn++tokenize :: Text.Text -> Main.UnstrippedTokens+tokenize = Monoid.mconcat . map Main.tokenize . Main.stripCpp+ . Main.annotate "fn"++plist :: (Show a) => [a] -> IO ()+plist xs = mapM_ (putStrLn . show) xs >> putChar '\n'++extractTokens :: Main.UnstrippedTokens -> [Text.Text]+extractTokens = map (\token -> case Main.valOf token of+ Token name -> name+ Newline n -> Text.pack ("nl " ++ show n)) . Main.unstrippedTokensOf++equal :: (Show a, Eq a) => Assert z -> a -> a -> IO ()+equal srcpos x y = unless (x == y) $+ putStrLn $ "__ " ++ getSourceLoc srcpos ++ " " ++ show x ++ " /= " ++ show y++type Assert a = Bool -> a -> String++-- | Awful ghc hack to get source line location.+getSourceLoc :: Assert a -> String+getSourceLoc assert_ = takeWhile (/=' ') $ Unsafe.unsafePerformIO $+ Exception.evaluate (assert_ False (error "Impossible"))+ `Exception.catch` (\(Exception.AssertionFailed s) -> return s)+