fast-tags 0.0.6 → 1.0
raw patch · 6 files changed
+1636/−283 lines, 6 filesdep +cpphsdep +deepseqdep +directorydep −ghcdep ~base
Dependencies added: cpphs, deepseq, directory, fast-tags, filepath, tasty, tasty-hunit
Dependencies removed: ghc
Dependency ranges changed: base
Files
- README +0/−2
- changelog.md +23/−0
- fast-tags.cabal +41/−22
- src/FastTags.hs +727/−230
- src/Main.hs +190/−29
- tests/MainTest.hs +655/−0
README view
@@ -3,6 +3,4 @@ TODO: -- Some files are not in UTF8. Use ByteString with a lenient decoder?- - \ continuation in strings is not parsed correctly.
changelog.md view
@@ -1,3 +1,26 @@+1.0:++* Merged a whole bunch of patches from Sergey Vinokurov. Copy paste from+<https://github.com/elaforge/fast-tags/pull/6>:++* recognize more syntactic constructs (consider tests as specification of+what's handled)++* add more tests++* use tasty to organize tests++* ability to produce emacs tags++* handling of literate files++* new mode to recursively traverse directory tree and search for haskell files++* optionally ignore encoding errors during reading and skip offending files++* ability to read \n-separated or \0-separated list of files from stdin+and blazing-fast speed of tag generation is presevred+ 0.0.6: * fix bug where class context in a class's methods would be confused for the
fast-tags.cabal view
@@ -1,12 +1,12 @@ name: fast-tags-version: 0.0.6+version: 1.0 cabal-version: >= 1.8 build-type: Simple-synopsis: Fast incremental vi tags.+synopsis: Fast incremental vi and emacs tags. description: Yet another tags program. Like hasktags, it uses its own parser rather than haskell-src or haskell-src-exts, so it's fast. It understands- hsc files, though not literate haskell.+ hsc and literate haskell. . In addition, it will load an existing tags file and merge generated tags. .@@ -16,15 +16,9 @@ . Limitations: .- - No emacs tags, but they would be easy to add.- .- - Not using a real haskell parser means there are more likely to be dark+ - Not using a real haskell parser means there is likely to be dark corners that don't parse right. .- - Only top-level functions with type declarations are tagged. Top-level- functions without type declarations are skipped, as are ones inside 'let'- or 'where'.- . - Code has to be indented \"properly\", so brace and semicolon style with strange dedents will probably confuse it. @@ -45,21 +39,46 @@ type: git location: git://github.com/elaforge/fast-tags.git -executable fast-tags- main-is: Main.hs+flag fast+ description:+ Spend more time optimizing a program (may yield up to 25% speedup)+ default: False++library+ build-depends:+ base >= 3 && < 5, containers, cpphs >1.18, filepath, directory,+ -- text 0.11.1.12 has a bug.+ text (> 0.11.1.12 || < 0.11.1.12), deepseq+ exposed-modules: FastTags hs-source-dirs: src- build-depends: base >= 3 && < 5, containers,+ ghc-options: -Wall -fno-warn-name-shadowing+ ghc-prof-options: -Wall -fno-warn-name-shadowing -auto-all+ if flag(fast)+ ghc-options:+ -funfolding-creation-threshold=10000 -funfolding-use-threshold=2500++executable fast-tags+ main-is: src/Main.hs+ build-depends:+ base >= 3 && < 5, containers, filepath, directory, -- text 0.11.1.12 has a bug.- text (> 0.11.1.12 || < 0.11.1.12)+ text (> 0.11.1.12 || < 0.11.1.12),+ fast-tags ghc-options: -Wall -fno-warn-name-shadowing+ ghc-prof-options: -Wall -fno-warn-name-shadowing -auto-all+ if flag(fast)+ ghc-options:+ -funfolding-creation-threshold=10000 -funfolding-use-threshold=2500 -test-suite tests+test-suite test-fast-tags type: exitcode-stdio-1.0- hs-source-dirs: src- main-is: Main_test.hs- build-depends: ghc,- base >= 3 && < 5, containers,+ main-is: MainTest.hs+ hs-source-dirs: tests+ ghc-options: -main-is MainTest+ ghc-prof-options: -main-is MainTest+ build-depends:+ base >= 3 && < 5, containers, filepath, directory, -- text 0.11.1.12 has a bug.- text (> 0.11.1.12 || < 0.11.1.12)- -- Needed for the srcloc hack.- ghc-options: -fno-ignore-asserts+ text (> 0.11.1.12 || < 0.11.1.12),+ tasty, tasty-hunit,+ fast-tags
src/FastTags.hs view
@@ -1,69 +1,115 @@-{-# LANGUAGE OverloadedStrings, PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+ {-# OPTIONS_GHC -funbox-strict-fields #-}-module FastTags where-import qualified Control.Exception as Exception++module FastTags+ ( isHsFile+ , isLiterateFile+ , merge+ , TokenVal(..)+ , TagVal(..)+ , Type(..)+ , Tag(..)+ , Pos(..)+ , SrcPos(..)+ , UnstrippedTokens(..)+ , breakString+ , stripComments+ , processFile+ , processAll+ , process+ , tokenize+ , stripCpp+ , annotate+ , stripNewlines+ , breakBlocks+ , unstrippedTokensOf+ , split+ )+where++import Control.Arrow ((***), (&&&)) import Control.Monad-import qualified Data.Char as Char-import qualified Data.List as List-import qualified Data.Monoid as Monoid-import Data.Monoid ((<>))-import qualified Data.Set as Set-import qualified Data.Text as T+import Control.DeepSeq (NFData, rnf)+import Data.Function (on)+import Data.Functor ((<$>))+import Data.Monoid (Monoid, (<>), mconcat) import Data.Text (Text)-import qualified Data.Text.IO as Text.IO+import qualified System.Exit as Exit -import qualified Debug.Trace as Trace+import qualified Language.Preprocessor.Unlit as Unlit+import Text.Printf (printf)++import qualified Control.Exception as Exception+import qualified Data.Char as Char+import qualified Data.IntSet as IntSet+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.IO as T import qualified System.IO as IO-import qualified System.IO.Error as IO.Error -mergeTags :: [FilePath] -> [Text] -> [Pos TagVal] -> [Text]-mergeTags inputs old new =- -- '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+-- * types --- | Documented in vim :h tags-file-format.--- This tells vim that the file is sorted (but not case folded) so that--- it can do a bsearch and never needs to fall back to linear search.-vimMagicLine :: Text-vimMagicLine = "!_TAG_FILE_SORTED\t1\t~"+data TagVal = TagVal+ !Text -- ^ prefix+ !Text -- ^ name+ !Type -- ^ tag type+ deriving (Show) -isNewTag :: Set.Set Text -> Text -> Bool-isNewTag textFns line = Set.member fn textFns- where fn = T.takeWhile (/='\t') $ T.drop 1 $ T.dropWhile (/='\t') line+instance NFData TagVal where+ rnf (TagVal x y z) = rnf x `seq` rnf y `seq` rnf z --- | Convert a Tag to text, e.g.: AbsoluteMark\tCmd/TimeStep.hs 67 ;" f-showTag :: Pos TagVal -> Text-showTag (Pos (SrcPos fn lineno) (Tag text typ)) =- T.concat [text, "\t", T.pack fn, "\t", T.pack (show lineno), " ;\" ",- T.singleton (showType typ)]+instance Eq TagVal where+ TagVal _ name t == TagVal _ name' t' = name == name' && t == t' --- | Vim takes this to be the \"kind:\" annotation. It's just an arbitrary--- string and these letters conform to no standard. Presumably there are some--- vim extensions that can make use of it.-showType :: Type -> Char-showType typ = case typ of- Module -> 'm'- Function -> 'f'- Class -> 'c'- Type -> 't'- Constructor -> 'C'+instance Ord TagVal where+ compare (TagVal _ name t) (TagVal _ name' t') =+ name `compare` name' <> t `compare` t' --- * types+-- don't swap constructors since we rely that Type < Constructor == True holds+data Type =+ Function+ | Type+ | Constructor+ | Class+ | Module+ | Operator+ | Pattern+ deriving (Eq, Ord, Show) -data TagVal = Tag !Text !Type- deriving (Eq, Show)+instance NFData Type where+ rnf t = t `seq` () -data Type = Module | Function | Class | Type | Constructor- deriving (Eq, Show)+data TokenVal =+ Token !Text !Text+ | Newline !Int -- ^ indentation+ deriving (Show) -data TokenVal = Token !Text | Newline !Int- deriving (Eq, Show)+tokenName :: TokenVal -> Text+tokenName (Token _ name) = name+tokenName _ = error "cannot extract name from non-Token TokenVal" -type Tag = Either String (Pos TagVal)+data Tag =+ Tag !(Pos TagVal)+ | RepeatableTag !(Pos TagVal)+ | Warning !String+ deriving (Show, Eq, Ord)++partitionTags :: [Tag] -> ([Pos TagVal], [Pos TagVal], [String])+partitionTags ts = go ts [] [] []+ where+ go [] xs ys zs = (xs, ys, reverse zs)+ go (Tag t : ts) xs ys zs = go ts (t:xs) ys zs+ go (RepeatableTag t : ts) xs ys zs = go ts xs (t:ys) zs+ go (Warning warn : ts) xs ys zs = go ts xs ys (warn:zs)+ type Token = Pos TokenVal -- | Newlines have to remain in the tokens because 'breakBlocks' relies on@@ -71,7 +117,7 @@ -- newlines might be anywhere. A newtype makes sure that the tokens only get -- stripped once and that I don't do any pattern matching on unstripped tokens. newtype UnstrippedTokens = UnstrippedTokens [Token]- deriving (Show, Monoid.Monoid)+ deriving (Show, Monoid) mapTokens :: ([Token] -> [Token]) -> UnstrippedTokens -> UnstrippedTokens mapTokens f (UnstrippedTokens tokens) = UnstrippedTokens (f tokens)@@ -79,18 +125,34 @@ unstrippedTokensOf :: UnstrippedTokens -> [Token] unstrippedTokensOf (UnstrippedTokens tokens) = tokens +-- | Drop @n@ non-newline tokens.+dropTokens :: Int -> UnstrippedTokens -> UnstrippedTokens+dropTokens n = mapTokens (f n)+ where+ f :: Int -> [Token] -> [Token]+ f 0 xs = xs+ f _ [] = []+ f n (Pos _ (Newline _) : xs) = f n xs+ f n (Pos _ (Token _ _) : xs) = f (n - 1) xs+ type Line = Pos Text data Pos a = Pos { posOf :: !SrcPos , valOf :: !a- }+ } deriving (Eq, Ord) +instance (NFData a) => NFData (Pos a) where+ rnf (Pos x y) = rnf x `seq` rnf y+ data SrcPos = SrcPos {- posFile :: !FilePath- , posLine :: !Int- } deriving (Eq)+ _posFile :: !FilePath+ , posLine :: !Int+ } deriving (Eq, Ord) +instance NFData SrcPos where+ rnf (SrcPos x y) = rnf x `seq` rnf y+ instance Show a => Show (Pos a) where show (Pos pos val) = show pos ++ ":" ++ show val instance Show SrcPos where@@ -99,44 +161,100 @@ -- * process -- | Global processing for when all tags are together.-processAll :: [Pos TagVal] -> [Pos TagVal]-processAll = sortDups . dropDups (\t -> (posOf t, tagText t))- . sortOn tagText+processAll :: [[Pos TagVal]] -> [Pos TagVal]+processAll =+ sortDups . dropDups isDuplicatePair+ . combineBalanced (mergeOn tagSortingKey)+ . map (dropDups isDuplicatePair)+ where+ isDuplicatePair :: Pos TagVal -> Pos TagVal -> Bool+ isDuplicatePair t t' =+ posOf t == posOf t'+ && tagText t == tagText t'+ && tagType t == tagType t' +combineBalanced :: forall a. (a -> a -> a) -> [a] -> a+combineBalanced f xs = go xs+ where+ go :: [a] -> a+ go [] = error "cannot combine empty list"+ go xs@(_:_) = case combine xs of+ [] -> error "unexpected empty list when combining nonempty lists"+ [x] -> x+ xs' -> go xs'+ combine :: [a] -> [a]+ combine [] = []+ combine [x] = [x]+ combine (x:x':xs) = f x x' : combine xs+ -- | 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+sortDups = concatMap (sortOn tagType) . M.elems . M.fromAscListWith (++)+ . map (fst . tagSortingKey &&& (:[])) tagText :: Pos TagVal -> Text-tagText (Pos _ (Tag text _)) = text+tagText (Pos _ (TagVal _ text _)) = text +tagType :: Pos TagVal -> Type+tagType (Pos _ (TagVal _ _ t)) = t++tagLine :: Pos TagVal -> Int+tagLine (Pos (SrcPos _ line) _) = line+ -- | Read tags from one file.-processFile :: FilePath -> IO [Tag]-processFile fn = fmap (process fn) (Text.IO.readFile fn)+processFile :: Bool -> FilePath -> Bool -> IO ([Pos TagVal], [String])+processFile ignoreEncodingErrors fn trackPrefixes =+ fmap (process fn trackPrefixes) (T.readFile fn) `Exception.catch` \(exc :: Exception.SomeException) -> do -- readFile will crash on files that are not UTF8. Unfortunately not -- all haskell source file are.- IO.hPutStrLn IO.stderr $ "exception reading " ++ show fn ++ ": "- ++ show exc- return []+ IO.hPutStrLn IO.stderr $+ "exception reading " ++ show fn ++ ": " ++ show exc+ unless ignoreEncodingErrors $+ void $ Exit.exitFailure+ return ([], []) +tagSortingKey :: Pos TagVal -> (Text, Type)+tagSortingKey (Pos _ (TagVal _ name t)) = (name, t)+ -- | Process one file's worth of tags.-process :: FilePath -> Text -> [Tag]-process fn = concatMap blockTags . breakBlocks . stripComments- . Monoid.mconcat . map tokenize . stripCpp . annotate fn+process :: FilePath -> Bool -> Text -> ([Pos TagVal], [String])+process fn trackPrefixes =+ splitAndRemoveRepeats . concatMap blockTags . breakBlocks . stripComments+ . mconcat . map (tokenize trackPrefixes) . stripCpp . annotate fn+ . unlit'+ where+ splitAndRemoveRepeats :: [Tag] -> ([Pos TagVal], [String])+ splitAndRemoveRepeats tags =+ (mergeOn tagSortingKey (sortOn tagSortingKey newTags) earliestRepeats,+ warnings)+ where+ (newTags, repeatableTags, warnings) = partitionTags tags+ earliestRepeats :: [Pos TagVal]+ earliestRepeats = M.elems $ M.fromListWith minLine $+ map (tagSortingKey &&& id) repeatableTags+ minLine x y+ | tagLine x < tagLine y = x+ | otherwise = y+ unlit' :: Text -> Text+ unlit' s+ | isLiterateFile fn = T.pack $ Unlit.unlit fn $ T.unpack s'+ | otherwise = s+ where+ s' :: Text+ s' | "\\begin{code}" `T.isInfixOf` s && "\\end{code}" `T.isInfixOf` s =+ T.unlines $ filter (not . birdLiterateLine) $ T.lines s+ | otherwise = s+ birdLiterateLine :: Text -> Bool+ birdLiterateLine xs+ | T.null xs = False+ | otherwise = case headt $ T.dropWhile Char.isSpace xs of+ Just '>' -> True+ _ -> False -- * tokenize @@ -148,294 +266,673 @@ stripCpp :: [Line] -> [Line] stripCpp = filter $ not . ("#" `T.isPrefixOf`) . valOf -tokenize :: Line -> UnstrippedTokens-tokenize (Pos pos line) = UnstrippedTokens $ map (Pos pos) (tokenizeLine line)+tokenize :: Bool -> Line -> UnstrippedTokens+tokenize trackPrefixes (Pos pos line) =+ UnstrippedTokens $ map (Pos pos) (tokenizeLine trackPrefixes line) -tokenizeLine :: Text -> [TokenVal]-tokenizeLine text = Newline nspaces : go line+spanToken :: Text -> (Text, Text)+spanToken text+ | T.null text = ("", "")+ -- Special case to prevent "--" from consuming too much input so that+ -- closing "-}" becomes unavailable.+ | Just rest <- T.stripPrefix "--}" text = ("-}", rest)+ | Just (sym, rest) <- consume comments text = (sym, rest)+ -- Find symbol that isn't followed by haskellOpChar.+ | Just (sym, rest) <- consume symbols text+ , maybe True (not . haskellOpChar) (headt rest)+ = (sym, rest)+ | c == '\'' = let (token, rest) = breakChar cs in (T.cons c token, rest)+ | c == '"' =+ let (token, rest) = breakString cs in (T.cons c token, rest)+ | state@(token, _) <- spanSymbol (haskellOpChar c) text,+ not (T.null token) = state+ -- This will tokenize differently than haskell should, e.g., 9x will+ -- be "9x" not "9" "x". But I just need a wordlike chunk, not an+ -- actual token. Otherwise I'd have to tokenize numbers.+ | otherwise = case T.span (identChar $ Char.isUpper c) text of+ ("", _) -> (T.singleton c, cs)+ (token, rest) -> (token, rest) where- nspaces = T.count " " spaces + T.count "\t" spaces * 8+ -- Safe because of null check above.+ Just (c, cs) = T.uncons text+ comments = ["{-", "-}"]+ symbols = ["--", "=>", "->", "::"]++tokenizeLine :: Bool -> Text -> [TokenVal]+tokenizeLine trackPrefixes text = Newline nspaces : go spaces line+ where+ nspaces = fromIntegral $ T.count " " spaces + T.count "\t" spaces * 8 (spaces, line) = T.break (not . Char.isSpace) text- symbols = ["--", "{-", "-}", "=>", "->", "::"]- go unstripped- | T.null text = []- | Just sym <- List.find (`T.isPrefixOf` text) symbols =- Token sym : go (T.drop (T.length sym) text)- | c == '\'' = let (token, rest) = breakChar text- in Token (T.cons c token) : go rest- | c == '"' = go (skipString cs)- | (token, rest) <- spanSymbol text, not (T.null token) =- Token token : go rest- -- This will tokenize differently than haskell should, e.g.- -- 9x will be "9x" not "9" "x". But I just need a wordlike chunk, not- -- an actual token. Otherwise I'd have to tokenize numbers.- | otherwise = case T.span identChar text of- ("", _) -> Token (T.singleton c) : go cs- (token, rest) -> Token token : go rest- where- text = T.dropWhile Char.isSpace unstripped- c = T.head text- cs = T.tail text+ go :: Text -> Text -> [TokenVal]+ go oldPrefix unstripped+ | T.null stripped = []+ | otherwise =+ let (token, rest) = spanToken stripped+ newPrefix = if trackPrefixes+ then oldPrefix <> spaces <> token+ else T.empty+ in Token newPrefix token : go newPrefix rest+ where (spaces, stripped) = T.break (not . Char.isSpace) unstripped startIdentChar :: Char -> Bool startIdentChar c = Char.isAlpha c || c == '_' -identChar :: Char -> Bool-identChar c = Char.isAlphaNum c || c == '.' || c == '\'' || c == '_'+identChar :: Bool -> Char -> Bool+identChar considerDot c = Char.isAlphaNum c || c == '\'' || c == '_' || c == '#'+ || considerDot && c == '.' +-- unicode operators are not supported yet+haskellOpChar :: Char -> Bool+haskellOpChar c = IntSet.member (Char.ord c) opChars+ where+ opChars :: IntSet.IntSet+ opChars = IntSet.fromList $ map Char.ord "-!#$%&*+./<=>?@^|~:\\"++isTypeVarStart :: Text -> Bool+isTypeVarStart x = case headt x of+ Just c -> Char.isLower c || c == '_'+ _ -> False+ -- | Span a symbol, making sure to not eat comments.-spanSymbol :: Text -> (Text, Text)-spanSymbol text- | any (`T.isPrefixOf` post) [",", "--", "-}", "{-"] = (pre, post)+spanSymbol :: Bool -> Text -> (Text, Text)+spanSymbol considerColon text+ | Just res <- haskellOp text [] = res+ | any (`T.isPrefixOf` post) [",", "--", "-}", "{-"] = split | Just (c, cs) <- T.uncons post, c == '-' || c == '{' =- let (pre2, post2) = spanSymbol cs+ let (pre2, post2) = spanSymbol considerColon cs in (pre <> T.cons c pre2, post2)- | otherwise = (pre, post)+ | otherwise = split where- (pre, post) = T.break (\c -> T.any (==c) "-{," || not (symbolChar c)) text+ split@(pre, post) = T.break+ (\c -> T.any (==c) "-{," || not (symbolChar considerColon c)) text -symbolChar :: Char -> Bool-symbolChar c = Char.isSymbol c || Char.isPunctuation c+ haskellOp :: Text -> [Char] -> Maybe (Text, Text)+ haskellOp txt op+ | Just (c, cs) <- T.uncons txt+ , haskellOpChar c+ , not $ "-}" `T.isPrefixOf` txt =+ haskellOp cs $ c : op+ | null op = Nothing+ | otherwise = Just (T.pack $ reverse op, txt) +symbolChar :: Bool -> Char -> Bool+symbolChar considerColon c =+ (Char.isSymbol c || Char.isPunctuation c)+ && (not (c `elem` "(),;[]`{}_:\"'") || considerColon && c == ':')+ breakChar :: Text -> (Text, Text)-breakChar text- | T.null text = ("", "")- | T.head text == '\\' = T.splitAt 3 text- | otherwise = T.splitAt 2 text+breakChar text = case headt text of+ Nothing -> ("", "")+ Just '\\' -> T.splitAt 3 text+ _ -> T.splitAt 2 text --- | Skip until the ending double-quote of a string. Tags never happen in--- strings so I don't need to keep it.--- -- TODO \ continuation isn't supported. I'd have to tokenize at the file -- level instead of the line level.-skipString :: Text -> Text-skipString text = case T.uncons (T.dropWhile (not . end) text) of- Nothing -> ""- Just (c, cs)- | c == '"' -> cs- | otherwise -> skipString (T.drop 1 cs)- where end c = c == '\\' || c == '"'+breakString :: Text -> (Text, Text)+breakString = (T.pack . reverse *** T.pack) . go [] . T.unpack+ where+ go :: String -> String -> (String, String)+ go s [] = (s, [])+ go s ('"':xs) = ('"': s, xs)+ go s ('\\':[]) = (s, "\\")+ -- handle string continuation+ go s ('\\':'\n':xs) = go s $ dropBackslash $+ dropWhile (\c -> c /= '\\' && c /= '"') xs+ go s ('\\':x:xs) = go (x : '\\': s) xs+ go s (x:xs) = go (x : s) xs + dropBackslash :: String -> String+ dropBackslash ('\\':xs) = xs+ dropBackslash xs = xs+ stripComments :: UnstrippedTokens -> UnstrippedTokens stripComments = mapTokens (go 0) where go :: Int -> [Token] -> [Token] go _ [] = [] go nest (pos@(Pos _ token) : rest)- | token == Token "--" = go nest (dropLine rest)- | token == Token "{-" = go (nest+1) rest- | token == Token "-}" = go (nest-1) rest- | nest > 0 = go nest rest- | otherwise = pos : go nest rest+ | token `nameStartsWith` "{-" = go (nest + 1) rest+ | token `nameEndsWith` "-}" = go (nest - 1) rest+ | nest == 0 && tokenNameSatisfies token isComment =+ go nest (dropLine rest)+ | nest > 0 = go nest rest+ | otherwise = pos : go nest rest+ dropLine :: [Token] -> [Token]+ dropLine = dropWhile (not . isNewline)+ isComment :: Text -> Bool+ isComment name =+ "--" `T.isPrefixOf` name+ && T.all (\c -> not (haskellOpChar c) || c == '-') (T.drop 2 name) -- | Break the input up into blocks based on indentation. breakBlocks :: UnstrippedTokens -> [UnstrippedTokens]-breakBlocks = map UnstrippedTokens . filter (not . null) . go . filterBlank- . unstrippedTokensOf+breakBlocks =+ map UnstrippedTokens . filter (not . null)+ . go . filterBlank . unstrippedTokensOf where- go [] = []+ go :: [Token] -> [[Token]]+ go [] = [] go tokens = pre : go post where (pre, post) = breakBlock tokens -- Blank lines mess up the indentation.+ filterBlank :: [Token] -> [Token] filterBlank [] = [] filterBlank (Pos _ (Newline _) : xs@(Pos _ (Newline _) : _)) = filterBlank xs filterBlank (x:xs) = x : filterBlank xs -- | Take until a newline, then take lines until the indent established after--- that newline decreases.+-- that newline decreases. Or, alternatively, if "{" is encountered then count+-- it as a block until closing "}" is found taking nesting into account. breakBlock :: [Token] -> ([Token], [Token])-breakBlock (t@(Pos _ tok):ts) = case tok of+breakBlock (t@(Pos _ tok) : ts) = case tok of Newline indent -> collectIndented indent ts- _ -> let (pre, post) = breakBlock ts in (t:pre, post)+ Token _ "{" -> collectBracedBlock breakBlock ts 1+ _ -> remember t $ breakBlock ts where- collectIndented indent (t@(Pos _ tok) : ts) = case tok of- Newline n | n <= indent -> ([], t:ts)- _ -> let (pre, post) = collectIndented indent ts in (t:pre, post)+ collectIndented :: Int -> [Token] -> ([Token], [Token])+ collectIndented indent tsFull@(t@(Pos _ tok) : ts) = case tok of+ Newline n | n <= indent -> ([], tsFull)+ Token _ "{" ->+ remember t $ collectBracedBlock (collectIndented indent) ts 1+ _ -> remember t $ collectIndented indent ts collectIndented _ [] = ([], [])-breakBlock [] = ([], []) + collectBracedBlock :: ([Token] -> ([Token], [Token])) -> [Token] -> Int+ -> ([Token], [Token])+ collectBracedBlock _ [] _ = ([], [])+ collectBracedBlock cont ts 0 = cont ts+ collectBracedBlock cont (t@(Pos _ (Token _ "{")) : ts) n =+ remember t $ collectBracedBlock cont ts $! n + 1+ collectBracedBlock cont (t@(Pos _ (Token _ "}")) : ts) n =+ remember t $ collectBracedBlock cont ts $! n - 1+ collectBracedBlock cont (t:ts) n =+ remember t $ collectBracedBlock cont ts n + remember :: Token -> ([Token], [Token]) -> ([Token], [Token])+ remember t (xs, ys) = (t : xs, ys)+breakBlock [] = ([], [])+ -- * extract tags -- | Get all the tags in one indented block.+-- TODO clean this up to require less nesting, and dropDataContext duplication blockTags :: UnstrippedTokens -> [Tag]-blockTags tokens = case stripNewlines tokens of+blockTags unstripped = case stripNewlines unstripped of [] -> []- Pos _ (Token "module") : Pos pos (Token name) : _ ->- [mktag pos (snd (T.breakOnEnd "." name)) Module]+ Pos _ (Token _ "module") : Pos pos (Token prefix name) : _ ->+ [mkTag pos prefix (snd (T.breakOnEnd "." name)) Module]+ Pos _ (Token _ "pattern") : Pos pos (Token prefix name) : _+ | maybe False Char.isUpper (headt name) ->+ [mkTag pos prefix name Pattern]+ Pos _ (Token _ "foreign") : decl -> foreignTags decl+ -- newtype instance * = ...+ Pos _ (Token _ "newtype") : Pos _ (Token _ "instance")+ : (dropDataContext -> Pos pos _: rest) ->+ newtypeTags pos rest -- newtype X * = X *- Pos _ (Token "newtype") : Pos pos (Token name) : rest ->- mktag pos name Type : newtypeTags pos rest+ Pos _ (Token _ "newtype")+ : (dropDataContext -> whole@(tok@(Pos pos (Token _ name)) : rest))+ | isTypeName name -> tokToTag tok Type : newtypeTags pos rest+ | otherwise -> tok' : newtypeTags pos' rest'+ where (pos', tok', rest') = recordInfixName Type whole -- type family X ...- Pos _ (Token "type") : Pos _ (Token "family") : Pos pos (Token name) : _ ->- [mktag pos name Type]+ Pos _ (Token _ "type") : Pos _ (Token _ "family")+ : (dropDataContext -> whole@(tok@(Pos _ (Token _ name)) : _))+ | isTypeFamilyName name -> [tokToTag tok Type]+ | otherwise -> [tok']+ where (_, tok', _) = recordInfixName Type whole -- type X * = ...- Pos _ (Token "type") : Pos pos (Token name) : _ -> [mktag pos name Type]+ Pos _ (Token _ "type")+ : (dropDataContext -> whole@(tok@(Pos _ (Token _ name)) : _))+ | isTypeName name -> [tokToTag tok Type]+ | otherwise -> [tok']+ where (_, tok', _) = recordInfixName Type whole -- data family X ...- Pos _ (Token "data") : Pos _ (Token "family") : Pos pos (Token name) : _ ->- [mktag pos name Type]+ Pos _ (Token _ "data") : Pos _ (Token _ "family")+ : (dropDataContext -> tok@(Pos _ (Token _ name)) : rest)+ | isTypeFamilyName name -> [tokToTag tok Type]+ | otherwise -> [tok']+ where (_, tok', _) = recordInfixName Type rest+ -- data instance * = ...+ -- data instance * where ...+ Pos _ (Token _ "data") : Pos _ (Token _ "instance")+ : (dropDataContext -> Pos pos _: _) ->+ dataConstructorTags pos (dropTokens 2 unstripped) -- data X * = X { X :: *, X :: * } -- data X * where ...- Pos _ (Token "data") : Pos pos (Token name) : _ ->- mktag pos name Type : dataTags pos (mapTokens (drop 2) tokens)+ Pos _ (Token _ "data")+ : (dropDataContext -> tok@(Pos pos (Token _ name)) : rest)+ | isTypeName name -> tokToTag tok Type+ : dataConstructorTags pos (dropTokens 2 unstripped)+ -- if token after data is not a type name then it isn't+ -- infix type as well since it may be only '(' or some+ -- lowercase name, either of which is not type constructor+ | otherwise -> let (pos', tok, _) = recordInfixName Type rest+ in tok : dataConstructorTags pos' (dropTokens 1 unstripped) -- class * => X where X :: * ...- Pos pos (Token "class") : _ -> classTags pos (mapTokens (drop 1) tokens)+ Pos pos (Token _ "class") : _ -> classTags pos (dropTokens 1 unstripped)++ Pos _ (Token _ "infix") : _ -> []+ Pos _ (Token _ "infixl") : _ -> []+ Pos _ (Token _ "infixr") : _ -> []+ -- instance * where data * = X :: * ...+ Pos pos (Token _ "instance") : _ ->+ instanceTags pos (dropTokens 1 unstripped) -- x, y, z :: *- stripped -> fst $ functionTags False stripped+ stripped -> toplevelFunctionTags stripped +isTypeFamilyName :: Text -> Bool+isTypeFamilyName = maybe False (\c -> Char.isUpper c || haskellOpChar c) . headt++isTypeName :: Text -> Bool+isTypeName x = case headt x of+ Just c -> Char.isUpper c || c == ':'+ _ -> False++dropDataContext :: [Token] -> [Token]+dropDataContext = stripParensKindsTypeVars . stripOptContext++recordInfixName :: Type -> [Token] -> (SrcPos, Tag, [Token])+recordInfixName tokenType tokens = (pos, tokToTag tok tokenType, rest)+ where (tok@(Pos pos _) : rest) = dropInfixTypeStart tokens++-- same as dropWhile with counting+dropInfixTypeStart :: [Token] -> [Token]+dropInfixTypeStart tokens = dropWhile f tokens+ where+ f (Pos _ (Token _ name)) = isInfixTypePrefix name || name == "`"+ f _ = False++ isInfixTypePrefix :: Text -> Bool+ isInfixTypePrefix =+ maybe False ((\c -> Char.isLower c || c == '(')) . headt+ -- | It's easier to scan for tokens without pesky newlines popping up -- everywhere. But I need to keep the newlines in in case I hit a @where@ -- and need to call 'breakBlocks' again. stripNewlines :: UnstrippedTokens -> [Token] stripNewlines = filter (not . isNewline) . (\(UnstrippedTokens t) -> t) +-- | Tags from foreign import.+--+-- e.g. @foreign import ccall safe \"name\" c_name :: ...@ will produce a tag+-- for @c_name@.+foreignTags :: [Token] -> [Tag]+foreignTags decl = case decl of+ Pos _ (Token _ "import") : decl'+ | name : _ <- dropBefore ((=="::") . tokenName . valOf) decl' ->+ [tokToTag name Pattern]+ _ -> []++toplevelFunctionTags :: [Token] -> [Tag]+toplevelFunctionTags toks = case tags of+ -- Tags of toplevel functions are all repeatable, even the ones that come+ -- from the type signature because there will definitely be tags from the+ -- body and they should be sorted out if type signature is present.+ [] -> functionTagsNoSig toks+ _ -> map toRepeatableTag $ tags+ where+ -- first try to detect tags from type signature, if it fails then+ -- do the actual work of detecting from body+ (tags, _) = functionTags False toks+ toRepeatableTag :: Tag -> Tag+ toRepeatableTag (Tag t) = RepeatableTag t+ toRepeatableTag t = t++functionTagsNoSig :: [Token] -> [Tag]+functionTagsNoSig toks = go toks+ where+ go :: [Token] -> [Tag]+ go [] = []+ go toks@(Pos _ (Token _ "(") : _) = go $ stripBalancedParens toks+ go (Pos pos (Token prefix name) : ts)+ -- this function does not analyze type signatures+ | name == "::" = []+ | name == "!" || name == "~" || name == "@" = go ts+ | name == "=" || name == "|" = case stripParens toks of+ Pos pos (Token prefix name) : _+ | functionName False name ->+ [mkRepeatableTag pos prefix name Function]+ | T.all haskellOpChar name ->+ [mkRepeatableTag pos prefix name Operator]+ _ -> []+ | name == "`" = case ts of+ Pos pos' (Token prefix' name') : _+ | functionName False name' ->+ [mkRepeatableTag pos' prefix' name' Function]+ _ -> go ts+ | T.all haskellOpChar name = [mkRepeatableTag pos prefix name Operator]+ | otherwise = go ts+ stripParens :: [Token] -> [Token]+ stripParens = dropWhile ((`hasName` "(") . valOf)+ -- | Get tags from a function type declaration: token , token , token :: -- Return the tokens left over. functionTags :: Bool -- ^ expect constructors, not functions -> [Token] -> ([Tag], [Token]) functionTags constructors = go [] where- go tags (Pos pos (Token name) : Pos _ (Token "::") : rest)- | Just name <- functionName constructors name =- (reverse $ mktag pos name Function : tags, rest)- go tags (Pos pos (Token name) : Pos _ (Token ",") : rest)- | Just name <- functionName constructors name =- go (mktag pos name Function : tags) rest+ opTag = if constructors then Constructor else Operator+ funcTag = if constructors then Constructor else Function+ go :: [Tag] -> [Token] -> ([Tag], [Token])+ go tags (Pos _ (Token _ "(") : Pos pos (Token _ name)+ : Pos _ (Token prefix ")") : Pos _ (Token _ "::") : rest) =+ (reverse $ mkTag pos prefix name opTag : tags, rest)+ go tags (Pos pos (Token prefix name) : Pos _ (Token _ "::") : rest)+ | functionName constructors name =+ (reverse $ mkTag pos prefix name funcTag : tags, rest)+ go tags (Pos _ (Token _ "(") : Pos pos (Token _ name)+ : Pos _ (Token prefix ")") : Pos _ (Token _ ",") : rest) =+ go (mkTag pos prefix name opTag : tags) rest+ go tags (Pos pos (Token prefix name) : Pos _ (Token _ ",") : rest)+ | functionName constructors name =+ go (mkTag pos prefix name funcTag : tags) rest go tags tokens = (tags, tokens) -functionName :: Bool -> Text -> Maybe Text-functionName constructors text- | isFunction text = Just text- | isOperator text && not (T.null stripped) = Just stripped- | otherwise = Nothing+functionName :: Bool -> Text -> Bool+functionName constructors text = isFunction text where isFunction text = case T.uncons text of- Just (c, cs) -> firstChar c && startIdentChar c && T.all identChar cs- Nothing -> False- firstChar = if constructors then Char.isUpper else not . Char.isUpper- -- Technically I could insist on colons if constructors is True, but- -- let's let ghc decide about the syntax.- isOperator text = "(" `T.isPrefixOf` text && ")" `T.isSuffixOf` text- && T.all symbolChar stripped- stripped = T.drop 1 $ T.take (T.length text - 1) text+ Just (c, cs) ->+ firstChar c && startIdentChar c && T.all (identChar True) cs+ Nothing -> False+ firstChar = if constructors+ then Char.isUpper+ else \c -> Char.isLower c || c == '_' -- | * = X * newtypeTags :: SrcPos -> [Token] -> [Tag] newtypeTags prevPos tokens = case dropUntil "=" tokens of- Pos pos (Token name) : _ -> [mktag pos name Constructor]+ Pos pos (Token prefix name) : rest ->+ let constructor = mkTag pos prefix name Constructor+ in case rest of+ Pos _ (Token _ "{") : Pos funcPos (Token funcPrefix funcName) : _ ->+ [constructor, mkTag funcPos funcPrefix funcName Function]+ _ ->+ [constructor] rest -> unexpected prevPos (UnstrippedTokens tokens) rest "newtype * =" -- | [] (empty data declaration) -- * = X { X :: *, X :: * } -- * where X :: * X :: * -- * = X | X-dataTags :: SrcPos -> UnstrippedTokens -> [Tag]-dataTags prevPos unstripped- | any ((== Token "where") . valOf) (unstrippedTokensOf unstripped) =+dataConstructorTags :: SrcPos -> UnstrippedTokens -> [Tag]+dataConstructorTags prevPos unstripped+ -- GADT+ | any ((`hasName` "where") . valOf) (unstrippedTokensOf unstripped) = concatMap gadtTags (whereBlock unstripped)- | otherwise = case dropUntil "=" (stripNewlines unstripped) of+ -- plain ADT+ | otherwise = case strip unstripped of [] -> [] -- empty data declaration- Pos pos (Token name) : rest ->- mktag pos name Constructor : collectRest rest+ rest | Just (Pos pos (Token prefix name), rest') <-+ extractInfixConstructor rest ->+ mkTag pos prefix name Constructor : collectRest rest'+ Pos pos (Token prefix name) : rest ->+ mkTag pos prefix name Constructor : collectRest rest rest -> unexpected prevPos unstripped rest "data * =" where+ strip = stripOptBang . stripOptContext . stripOptForall . dropUntil "="+ . stripNewlines+ collectRest :: [Token] -> [Tag] collectRest tokens | (tags@(_:_), rest) <- functionTags False tokens =- tags ++ collectRest rest- collectRest (Pos _ (Token "|") : Pos pos (Token name) : rest) =- mktag pos name Constructor : collectRest rest+ tags ++ collectRest (dropUntilNextField rest)+ collectRest (Pos pipePos (Token _ "|") : rest)+ | Just (Pos pos (Token prefix name), rest'') <-+ extractInfixConstructor rest' =+ mkTag pos prefix name Constructor : collectRest rest''+ | Pos pos (Token prefix name) : rest'' <- rest' =+ mkTag pos prefix name Constructor+ : collectRest (dropUntilNextCaseOrRecordStart rest'')+ | otherwise = error $+ printf "syntax error@%d: | not followed by tokens\n"+ (posLine pipePos)+ where+ rest' = stripOptBang $ stripOptContext $ stripOptForall rest collectRest (_ : rest) = collectRest rest collectRest [] = [] + stripOptBang :: [Token] -> [Token]+ stripOptBang ((Pos _ (Token _ "!")) : rest) = rest+ stripOptBang ts = ts++ extractInfixConstructor :: [Token] -> Maybe (Token, [Token])+ extractInfixConstructor = extract . stripTypeParam+ where+ extract :: [Token] -> Maybe (Token, [Token])+ extract (tok@(Pos _ (Token _ name)) : rest)+ | ":" `T.isPrefixOf` name = Just (tok, stripTypeParam rest)+ extract (Pos _ (Token _ "`") : tok@(Pos _ _) : Pos _ (Token _ "`")+ : rest) =+ Just (tok, stripTypeParam rest)+ extract _ = Nothing+ stripTypeParam :: [Token] -> [Token]+ stripTypeParam input@((Pos _ (Token _ "(")) : _) =+ stripBalancedParens input+ stripTypeParam input@((Pos _ (Token _ "[")) : _) =+ stripBalancedBrackets input+ stripTypeParam ts = drop 1 ts++ dropUntilNextCaseOrRecordStart :: [Token] -> [Token]+ dropUntilNextCaseOrRecordStart =+ dropWithStrippingBalanced (\x -> not $ x == "|" || x == "{")++ dropUntilNextField :: [Token] -> [Token]+ dropUntilNextField =+ dropWithStrippingBalanced (\x -> not $ x == "," || x == "}" || x == "|")++stripOptForall :: [Token] -> [Token]+stripOptForall (Pos _ (Token _ "forall") : rest) = dropUntil "." rest+stripOptForall xs = xs++stripParensKindsTypeVars :: [Token] -> [Token]+stripParensKindsTypeVars (Pos _ (Token _ "(") : xs) =+ stripParensKindsTypeVars xs+stripParensKindsTypeVars (Pos _ (Token _ "::") : xs) =+ stripParensKindsTypeVars $ tail $ dropWithStrippingBalanced (/= ")") xs+stripParensKindsTypeVars (Pos _ (Token _ name) : xs)+ | isTypeVarStart name = stripParensKindsTypeVars xs+stripParensKindsTypeVars xs = xs++stripOptContext :: [Token] -> [Token]+stripOptContext (stripBalancedParens -> (Pos _ (Token _ "=>") : xs)) = xs+stripOptContext (stripSingleClassContext -> Pos _ (Token _ "=>") : xs) = xs+stripOptContext xs = xs++stripSingleClassContext :: [Token] -> [Token]+stripSingleClassContext (Pos _ (Token _ name) : xs)+ | maybe False Char.isUpper (headt name) =+ dropWithStrippingBalanced isTypeVarStart xs+stripSingleClassContext xs = xs++-- | Drop all tokens for which @pred@ returns True, also drop+-- any parenthesized expressions.+dropWithStrippingBalanced :: (Text -> Bool) -> [Token] -> [Token]+dropWithStrippingBalanced pred input@(Pos _ (Token _ name) : xs)+ | name == "(" = dropWithStrippingBalanced pred $ stripBalancedParens input+ | name == "[" = dropWithStrippingBalanced pred $ stripBalancedBrackets input+ | pred name = dropWithStrippingBalanced pred xs+dropWithStrippingBalanced _ xs = xs++stripBalancedParens :: [Token] -> [Token]+stripBalancedParens = stripBalanced "(" ")"++stripBalancedBrackets :: [Token] -> [Token]+stripBalancedBrackets = stripBalanced "[" "]"++stripBalanced :: Text -> Text -> [Token] -> [Token]+stripBalanced open close (Pos _ (Token _ name) : xs)+ | name == open = go 1 xs+ where+ go :: Int -> [Token] -> [Token]+ go 0 xs = xs+ go !n (Pos _ (Token _ name) : xs)+ | name == open = go (n + 1) xs+ | name == close = go (n - 1) xs+ | otherwise = go n xs+ go n (_: xs) = go n xs+ go _ [] = []+stripBalanced _ _ xs = xs+ gadtTags :: UnstrippedTokens -> [Tag] gadtTags = fst . functionTags True . stripNewlines -- | * => X where X :: * ... classTags :: SrcPos -> UnstrippedTokens -> [Tag]-classTags prevPos unstripped = case dropContext (stripNewlines unstripped) of- Pos pos (Token name) : _ ->- -- Drop the where and start expecting functions.- mktag pos name Class : concatMap classBodyTags (whereBlock unstripped)- rest -> unexpected prevPos unstripped rest "class * =>"- where- dropContext tokens- | any ((== Token "=>") . valOf) (takeUntil "where" tokens) =- dropUntil "=>" tokens- | otherwise = tokens+classTags prevPos unstripped =+ case dropDataContext $ stripNewlines unstripped of+ whole@(tok@(Pos _ (Token _ name)) : _)+ -- Drop the where and start expecting functions.+ | isTypeName name -> tokToTag tok Class : cont+ | otherwise ->+ let (_, tok, _) = recordInfixName Class whole+ in tok : concatMap classBodyTags (whereBlock unstripped)+ where cont = concatMap classBodyTags (whereBlock unstripped)+ rest -> unexpected prevPos unstripped rest "class * =>" classBodyTags :: UnstrippedTokens -> [Tag] classBodyTags unstripped = case stripNewlines unstripped of- Pos _ (Token typedata) : Pos pos (Token name) : _- | typedata `elem` ["type", "data"] -> [mktag pos name Type]+ Pos _ (Token _ typedata) : Pos pos (Token prefix name) : _+ | typedata `elem` ["type", "data"] -> [mkTag pos prefix name Type] tokens -> fst $ functionTags False tokens -- | Skip to the where and split the indented block below it. whereBlock :: UnstrippedTokens -> [UnstrippedTokens] whereBlock = breakBlocks . mapTokens (dropUntil "where") +instanceTags :: SrcPos -> UnstrippedTokens -> [Tag]+instanceTags prevPos unstripped =+ -- instances can offer nothing but some fresh data constructors since+ -- the actual datatype is really declared in the class declaration+ concatMap (newtypeTags prevPos . unstrippedTokensOf)+ (filter isNewtypeDecl block)+ ++ concatMap (dataConstructorTags prevPos)+ (filter isDataDecl block)+ where+ block = whereBlock unstripped + isNewtypeDecl :: UnstrippedTokens -> Bool+ isNewtypeDecl (UnstrippedTokens (Pos _ (Token _ "newtype") : _)) = True+ isNewtypeDecl _ = False++ isDataDecl :: UnstrippedTokens -> Bool+ isDataDecl (UnstrippedTokens (Pos _ (Token _ "data") : _)) = True+ isDataDecl _ = False+ -- * util -mktag :: SrcPos -> Text -> Type -> Tag-mktag pos name typ = Right $ Pos pos (Tag name typ)+mkTag :: SrcPos -> Text -> Text -> Type -> Tag+mkTag pos prefix name typ = Tag $ Pos pos (TagVal prefix name typ) +mkRepeatableTag :: SrcPos -> Text -> Text -> Type -> Tag+mkRepeatableTag pos prefix name typ =+ RepeatableTag $ Pos pos (TagVal prefix name typ)++tokToTag :: Token -> Type -> Tag+tokToTag (Pos pos (Token prefix name)) t = mkTag pos prefix name t+ warning :: SrcPos -> String -> Tag-warning pos warn = Left $ show pos ++ ": " ++ warn+warning pos warn = Warning $ show pos ++ ": " ++ warn unexpected :: SrcPos -> UnstrippedTokens -> [Token] -> String -> [Tag] unexpected prevPos (UnstrippedTokens tokensBefore) tokensHere declaration = [warning pos ("unexpected " ++ thing ++ " after " ++ declaration)] where- thing = if null tokensHere then "end of block"- else show (valOf (head tokensHere))+ thing = maybe "end of block" (show . valOf) (mhead tokensHere) pos- | not (null tokensHere) = posOf (head tokensHere)- | not (null tokensBefore) = posOf (last tokensBefore)+ | Just t <- mhead tokensHere = posOf t+ | Just t <- mlast tokensBefore = posOf t | otherwise = prevPos -dropLine :: [Token] -> [Token]-dropLine = drop 1 . dropWhile (not . isNewline)- isNewline :: Token -> Bool isNewline (Pos _ (Newline _)) = True-isNewline _ = False+isNewline _ = False --- | Drop until a token, then drop that token.-dropUntil :: Text -> [Token] -> [Token]-dropUntil token = drop 1 . dropWhile ((/= Token token) . valOf)+hasName :: TokenVal -> Text -> Bool+hasName tok text = tokenNameSatisfies tok (== text) --- | Take until, but not including, a token.-takeUntil :: Text -> [Token] -> [Token]-takeUntil token = takeWhile ((/= Token token) . valOf)+nameStartsWith :: TokenVal -> Text -> Bool+nameStartsWith tok text = tokenNameSatisfies tok (text `T.isPrefixOf`) +nameEndsWith :: TokenVal -> Text -> Bool+nameEndsWith tok text = tokenNameSatisfies tok (text `T.isSuffixOf`) --- * misc+tokenNameSatisfies :: TokenVal -> (Text -> Bool) -> Bool+tokenNameSatisfies (Token _ name) pred = pred name+tokenNameSatisfies _ _ = False -tracem :: Show a => String -> a -> a-tracem msg x = Trace.trace (msg ++ ": " ++ show x) x+-- * generic utils --- | If @op@ raised ENOENT, return Nothing.-catchENOENT :: IO a -> IO (Maybe a)-catchENOENT op = Exception.handleJust (guard . IO.Error.isDoesNotExistError)- (const (return Nothing)) (fmap Just op)+-- | Try to match one of the given prefixes.+consume :: [Text] -> Text -> Maybe (Text, Text) -- ^ (prefix, remainder)+consume prefixes t =+ msum [(,) prefix <$> T.stripPrefix prefix t | prefix <- prefixes] -dropDups :: Eq k => (a -> k) -> [a] -> [a]-dropDups key (x:xs) = go x xs+-- | Drop until the element before the matching one. Return [] if the function+-- never matches.+dropBefore :: (a -> Bool) -> [a] -> [a]+dropBefore f = go where+ go [] = []+ go [_] = []+ go xs@(_ : rest@(y:_))+ | f y = xs+ | otherwise = go rest++dropDups :: (a -> a -> Bool) -> [a] -> [a]+dropDups cmp (x:xs) = go x xs+ where go a [] = [a] go a (b:bs)- | key a == key b = go a bs+ | cmp a 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))+dropUntil :: Text -> [Token] -> [Token]+dropUntil token = drop 1 . dropWhile (not . (`hasName` token) . valOf) --- | Merge sorted lists.+sortOn :: (Ord k) => (a -> k) -> [a] -> [a]+sortOn key = L.sortBy (compare `on` key)++-- | Split list into chunks delimited by specified element.+split :: (Eq a) => a -> [a] -> [[a]]+split _ [] = []+split x xs = xs': split x (drop 1 xs'')+ where (xs', xs'') = break (==x) xs++-- | Crude predicate for Haskell files+isHsFile :: FilePath -> Bool+isHsFile fn =+ ".hs" `L.isSuffixOf` fn || ".hsc" `L.isSuffixOf` fn || isLiterateFile fn++isLiterateFile :: FilePath -> Bool+isLiterateFile fn = ".lhs" `L.isSuffixOf` fn+ merge :: Ord a => [a] -> [a] -> [a]-merge [] ys = ys-merge xs [] = xs-merge (x:xs) (y:ys)- | x <= y = x : merge xs (y:ys)- | otherwise = y : merge (x:xs) ys+merge = mergeBy compare++mergeOn :: (Ord b) => (a -> b) -> [a] -> [a] -> [a]+mergeOn f = mergeBy (compare `on` f)++mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy f xs ys = go xs ys+ where+ go [] ys = ys+ go xs [] = xs+ go (x:xs) (y:ys) = case f x y of+ EQ -> x: y: go xs ys+ LT -> x: go xs (y:ys)+ GT -> y: go (x:xs) ys++headt :: Text -> Maybe Char+headt = fmap fst . T.uncons++mhead :: [a] -> Maybe a+mhead [] = Nothing+mhead (x:_) = Just x++mlast :: [a] -> Maybe a+mlast xs+ | null xs = Nothing+ | otherwise = Just (last xs)
src/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | Tagify haskell source. @@ -6,16 +7,26 @@ hsc. That way I can hook it to the editor's save action and always keep the tags up to date. -}-module Main where+module Main (main) where+import Control.Applicative import Control.Monad-import qualified Data.Either as Either+import Data.Map (Map)+import Data.Monoid+import Data.Set (Set)+import Data.Text (Text)+import System.Console.GetOpt+import System.Directory+ (doesFileExist, doesDirectoryExist, getDirectoryContents)+import System.FilePath ((</>))+import qualified System.Exit as Exit import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified System.Console.GetOpt as GetOpt import qualified System.Environment as Environment-import qualified System.Exit import qualified System.IO as IO import FastTags@@ -24,52 +35,202 @@ main :: IO () main = do args <- Environment.getArgs- (flags, inputs) <- case GetOpt.getOpt GetOpt.Permute options args of++ (flags, inputs) <- case getOpt Permute options args of (flags, inputs, []) -> return (flags, inputs)- (_, _, errs) -> usage $ "flag errors:\n" ++ List.intercalate ", " errs+ (_, _, errs) ->+ let errMsg = "flag errors:\n" ++ List.intercalate ", " errs+ in usage $ errMsg ++ "\n" ++ help++ when (Help `elem` flags) $ usage help++ let verbose = Verbose `elem` flags+ emacs = ETags `elem` flags+ vim = not emacs+ trackPrefixes = emacs+ recurse = Recurse `elem` flags+ output = last $ defaultOutput : [fn | Output fn <- flags]+ noMerge = NoMerge `elem` flags+ useZeroSep = ZeroSep `elem` flags+ ignoreEncErrs = IgnoreEncodingErrors `elem` flags+ sep = if useZeroSep then '\0' else '\n'+ defaultOutput = if vim then "tags" else "TAGS"+ inputsM = if null inputs+ then split sep <$> getContents+ else fmap concat $ forM inputs $ \input -> do+ -- if an input is a directory then we find the+ -- haskell files inside it, optionally recursing+ -- further if the -R switch is specified+ isDirectory <- doesDirectoryExist input+ if isDirectory+ then filter isHsFile <$> contents recurse input+ else return [input]++ oldTags <- if vim && not noMerge+ then do+ exists <- doesFileExist output+ if exists+ then Text.lines <$> Text.IO.readFile output+ else return [vimMagicLine]+ else return [] -- we do not support tags merging for emacs for now++ inputs <- inputsM when (null inputs) $- usage "no input files\n"- let output = last $ "tags" : [fn | Output fn <- flags]- verbose = Verbose `elem` flags- oldTags <- fmap (maybe [vimMagicLine] Text.lines) $- catchENOENT $ Text.IO.readFile output+ usage "no input files on either command line or stdin\n" -- 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) $+ newTags <- fmap processAll $ 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+ (newTags, warnings) <- processFile ignoreEncErrs fn trackPrefixes+ forM_ warnings printErr when verbose $ do- let line = show i ++ " of " ++ show (length inputs - 1)- ++ ": " ++ fn+ let line = take 78 $ show i ++ ": " ++ 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+ let write = if output == "-"+ then Text.IO.hPutStr IO.stdout else Text.IO.writeFile output- write $ Text.unlines (mergeTags inputs oldTags newTags)++ write $ if vim+ then Text.unlines $ mergeTags inputs oldTags newTags+ else Text.concat $ prepareEmacsTags newTags+ where- usage msg = do- putStr $ GetOpt.usageInfo- (msg ++ "\nusage: fast-tags file1 file2 ...") options- System.Exit.exitFailure+ usage msg = putStr (GetOpt.usageInfo msg options) >> Exit.exitFailure -data Flag = Output FilePath | Verbose+ printErr :: String -> IO ()+ printErr = IO.hPutStrLn IO.stderr++ contents recurse =+ if recurse then getRecursiveDirContents else getProperDirContents++-- | Get all absolute filepaths contained in the supplied topdir,+-- except "." and ".."+getProperDirContents :: FilePath -> IO [FilePath]+getProperDirContents topdir = do+ names <- getDirectoryContents topdir+ let properNames = filter (`notElem` [".", ".."]) names+ return $ map ((</>) topdir) properNames++-- | Recurse directories collecting all files+getRecursiveDirContents :: FilePath -> IO [FilePath]+getRecursiveDirContents topdir = do+ paths <- getProperDirContents topdir+ paths' <- forM paths $ \path -> do+ isDirectory <- doesDirectoryExist path+ if isDirectory+ then getRecursiveDirContents path+ else return [path]+ return (concat paths')+++type TagsTable = Map FilePath [Pos TagVal]++prepareEmacsTags :: [Pos TagVal] -> [Text]+prepareEmacsTags = printTagsTable . classifyTagsByFile++printTagsTable :: TagsTable -> [Text]+printTagsTable = map (uncurry printSection) . Map.assocs++printSection :: FilePath -> [Pos TagVal] -> Text+printSection file tags = Text.concat+ ["\x0c\x0a", Text.pack file, ","+ , Text.pack $ show tagsLength, "\x0a", tagsText+ ]+ where+ tagsText = Text.unlines $ map printEmacsTag tags+ tagsLength = Text.length tagsText++printEmacsTag :: Pos TagVal -> Text+printEmacsTag (Pos (SrcPos _file line) (TagVal prefix _text _type)) =+ Text.concat [prefix, "\x7f", Text.pack (show line)]++classifyTagsByFile :: [Pos TagVal] -> TagsTable+classifyTagsByFile = foldr insertTag Map.empty++insertTag :: Pos TagVal -> TagsTable -> TagsTable+insertTag tag@(Pos (SrcPos file _) _) table =+ Map.insertWith (<>) file [tag] table++mergeTags :: [FilePath] -> [Text] -> [Pos TagVal] -> [Text]+mergeTags inputs old new =+ -- '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 Text.pack inputs++data Flag = Output FilePath+ | Help+ | Verbose+ | ETags+ | Recurse+ | NoMerge+ | ZeroSep+ | IgnoreEncodingErrors deriving (Eq, Show) -options :: [GetOpt.OptDescr Flag]+help :: String+help = "usage: fast-tags [options] [filenames]\n" +++ "In case no filenames provided on commandline, fast-tags expects " +++ "list of files separated by newlines in stdin."++options :: [OptDescr Flag] options =- [ GetOpt.Option ['o'] [] (GetOpt.ReqArg Output "filename")+ [ Option ['h'] ["help"] (NoArg Help)+ "print help message"+ , Option ['o'] [] (ReqArg Output "file") "output file, defaults to 'tags'"- , GetOpt.Option ['v'] [] (GetOpt.NoArg Verbose)+ , Option ['e'] [] (NoArg ETags)+ "print tags in Emacs format"+ , Option ['v'] [] (NoArg Verbose) "print files as they are tagged, useful to track down slow files"+ , Option ['R'] [] (NoArg Recurse)+ "read all files under any specified directories recursively"+ , Option ['0'] [] (NoArg ZeroSep)+ "expect list of file names in stdin to be 0-separated."+ , Option [] ["nomerge"] (NoArg NoMerge)+ "do not merge tag files"+ , Option [] ["ignore-encoding-errors"] (NoArg IgnoreEncodingErrors)+ "do exit on utf8 encoding error and continue processing other files" ]++-- | Documented in vim :h tags-file-format.+-- This tells vim that the file is sorted (but not case folded) so that+-- it can do a bsearch and never needs to fall back to linear search.+vimMagicLine :: Text+vimMagicLine = "!_TAG_FILE_SORTED\t1\t~"++isNewTag :: Set Text -> Text -> Bool+isNewTag textFns line = Set.member fn textFns+ where+ fn = Text.takeWhile (/='\t') $ Text.drop 1 $ Text.dropWhile (/='\t') line++-- | Convert a Tag to text, e.g.: AbsoluteMark\tCmd/TimeStep.hs 67 ;" f+showTag :: Pos TagVal -> Text+showTag (Pos (SrcPos fn lineno) (TagVal _ text typ)) = Text.concat+ [ text, "\t"+ , Text.pack fn, "\t"+ , Text.pack (show lineno), " ;\" "+ , Text.singleton (showType typ)+ ]++-- | Vim takes this to be the \"kind:\" annotation. It's just an arbitrary+-- string and these letters conform to no standard. Presumably there are some+-- vim extensions that can make use of it.+showType :: Type -> Char+showType typ = case typ of+ Module -> 'm'+ Function -> 'f'+ Class -> 'c'+ Type -> 't'+ Constructor -> 'C'+ Operator -> 'o'+ Pattern -> 'p'
+ tests/MainTest.hs view
@@ -0,0 +1,655 @@+{-# LANGUAGE OverloadedStrings #-}++module MainTest where++import qualified Control.Exception as Exception+import Control.Monad+import qualified Data.Either as Either+import qualified Data.Monoid as Monoid+import Data.Text (Text)+import qualified Data.Text as T++import Control.Exception (assert)+import qualified System.IO.Unsafe as Unsafe++import qualified FastTags+import FastTags (UnstrippedTokens(..), TokenVal(..), TagVal(..), Type(..), Tag, Pos(..))++import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain tests+++tests :: TestTree+tests = testGroup "tests"+ [ testTokenize+ , testSkipString+ , testStripComments+ , testBreakBlocks+ , testProcessAll+ , testProcess+ ]++test :: (Show a, Eq b, Show b) => (a -> b) -> a -> b -> TestTree+test f x expected = testCase (take 70 $ show x) $ f x @?= expected++testTokenize :: TestTree+testTokenize = testGroup "tokenize"+ [ "a::b->c" ==> ["a", "::", "b", "->", "c"]+ , "x{-\n bc#-}\n" ==> ["x", "{-", "nl 2", "bc#", "-}"]+ , "X.Y" ==> ["X.Y"]+ , "x9" ==> ["x9"]+ -- , "9x" ==> ["nl 0", "9", "x"]+ , "x :+: y" ==> ["x", ":+:", "y"]+ , "(#$)" ==> ["(", "#$", ")"]+ , "Data.Map.map" ==> ["Data.Map.map"]+ , "Map.map" ==> ["Map.map"]+ , "forall a. f a" ==> ["forall", "a", ".", "f", "a"]+ , "forall a . Foo" ==> ["forall", "a", ".", "Foo"]+ , "forall a. Foo" ==> ["forall", "a", ".", "Foo"]+ , "forall a .Foo" ==> ["forall", "a", ".", "Foo"]+ , "forall a.Foo" ==> ["forall", "a", ".", "Foo"]+ , "$#-- hi" ==> ["$#--", "hi"]+ , "(*), (-)" ==> ["(", "*", ")", ",", "(", "-", ")"]+ , "(.::)" ==> ["(", ".::", ")"]+ -- we rely on this behavior+ , "data (:+) a b" ==> ["data", "(", ":+", ")", "a", "b"]+ , "data (.::+::) a b" ==> ["data", "(", ".::+::", ")", "a", "b"]+ ]+ where+ (==>) = test f+ f = tail . extractTokens . tokenize++testSkipString :: TestTree+testSkipString = testGroup "skipString"+ [ "hi \" there" ==> " there"+ , "hi \\a \" there" ==> " there"+ , "hi \\\" there\"" ==> ""+ , "hi" ==> ""+ -- String continuation+ , test f' "hi \\\n \\bar\" baz" ("hi bar\"", " baz")+ ]+ where+ (==>) = test f+ f = snd . FastTags.breakString+ f' = FastTags.breakString++testStripComments :: TestTree+testStripComments = testGroup "stripComments"+ [ "hello -- there" ==> ["nl 0", "hello"]+ , "hello --there" ==> ["nl 0", "hello"]+ , "hello {- there -} fred" ==> ["nl 0", "hello", "fred"]+ , "hello -- {- there -}\nfred" ==> ["nl 0", "hello", "nl 0", "fred"]+ , "{-# LANG #-} hello {- there {- nested -} comment -} fred" ==> ["nl 0", "hello", "fred"]+ , "hello {-\nthere\n------}\n fred" ==> ["nl 0", "hello", "nl 1", "fred"]+ , "hello {- \nthere\n ------} \n fred" ==> ["nl 0", "hello", "nl 1", "fred"]+ , "hello {-\nthere\n-----}\n fred" ==> ["nl 0", "hello", "nl 1", "fred"]+ , "hello {- \nthere\n -----} \n fred" ==> ["nl 0", "hello", "nl 1", "fred"]+ , "hello {-\n-- there -}" ==> ["nl 0", "hello"]+ , "foo --- my comment\n--- my other comment\nbar" ==> ["nl 0", "foo", "nl 0", "nl 0", "bar"]+ ]+ where+ (==>) = test f+ f = extractTokens . FastTags.stripComments . tokenize++testBreakBlocks :: TestTree+testBreakBlocks = testGroup "breakBlocks"+ [ "1\n2\n" ==> [["1"], ["2"]]+ , "1\n 1\n2\n" ==> [["1", "1"], ["2"]]+ , "1\n 1\n 1\n2\n" ==> [["1", "1", "1"], ["2"]]+ -- intervening blank lines are ignored+ , "1\n 1\n\n 1\n2\n" ==> [["1", "1", "1"], ["2"]]+ , "1\n\n\n 1\n2\n" ==> [["1", "1"], ["2"]]++ , "1\n 11\n 11\n" ==> [["1", "11", "11"]]+ , " 11\n 11\n" ==> [["11"], ["11"]]+ ]+ where+ (==>) = test f+ f = map (extractTokens . UnstrippedTokens . FastTags.stripNewlines)+ . FastTags.breakBlocks . tokenize++testProcessAll :: TestTree+testProcessAll = testGroup "processAll"+ [ ["data X", "module X"] ==> ["fn0:1 X Type", "fn1:1 X Module"]+ -- Type goes ahead of Module.+ , ["module X\n\+ \data X"] ==> ["fn0:2 X Type", "fn0:1 X Module"]+ -- Extra X was filtered.+ , ["module X\n\+ \data X = X\n"] ==> ["fn0:2 X Type", "fn0:2 X Constructor", "fn0:1 X Module"]+ , ["module X\n\+ \data X a =\n\+ \ X a\n"] ==> ["fn0:2 X Type", "fn0:3 X Constructor", "fn0:1 X Module"]+ , ["newtype A f a b = A\n\+ \ { unA :: f (a -> b) }"]+ ==> ["fn0:1 A Type", "fn0:1 A Constructor", "fn0:2 unA Function"]+ ]+ where+ (==>) = test f+ f = map showTag+ . FastTags.processAll+ . map (\(i, t) -> fst $ FastTags.process ("fn" ++ show i) False t)+ . zip [0..]+ showTag (Pos p (TagVal _ text typ)) =+ unwords [show p, T.unpack text, show typ]++testProcess :: TestTree+testProcess = testGroup "process"+ [ testMisc+ , testData+ , testGADT+ , testFamilies+ , testFunctions+ , testClass+ , testInstance+ , testLiterate+ , testPatterns+ , testFFI+ ]++testMisc :: TestTree+testMisc = testGroup "misc"+ [ "module Bar.Foo where\n"+ ==>+ [TagVal "module Bar.Foo" "Foo" Module]+ , "newtype Foo a b =\n\+ \\tBar x y z\n"+ ==>+ [ TagVal "\tBar" "Bar" Constructor+ , TagVal "newtype Foo" "Foo" Type+ ]+ , "f :: A -> B\n\+ \g :: C -> D\n\+ \data D = C {\n\+ \\tf :: A\n\+ \\t}\n"+ ==>+ [ TagVal "data D = C" "C" Constructor+ , TagVal "data D" "D" Type+ , TagVal "\tf" "f" Function+ , TagVal "f" "f" Function+ , TagVal "g" "g" Function+ ]+ ]+ where+ (==>) = test f+ f = map valOf . fst . FastTags.process "fn.hs" False++testData :: TestTree+testData = testGroup "data"+ [ "data X\n" ==> ["X"]+ , "data X = X Int\n" ==> ["X", "X"]+ , "data Foo = Bar | Baz" ==> ["Bar", "Baz", "Foo"]+ , "data Foo =\n\tBar\n\t| Baz" ==> ["Bar", "Baz", "Foo"]+ -- Records.+ , "data Foo a = Bar { field :: Field }" ==> ["Bar", "Foo", "field"]+ , "data R = R { a::X, b::Y }" ==> ["R", "R", "a", "b"]+ , "data R = R {\n\ta::X\n\t, b::Y\n\t}" ==> ["R", "R", "a", "b"]+ , "data R = R {\n\ta,b::X\n\t}" ==> ["R", "R", "a", "b"]++ , "data R = R {\n\+ \ a :: !RealTime\n\+ \ , b :: !RealTime\n\+ \}"+ ==>+ ["R", "R", "a", "b"]+ , "data Rec = Rec {\n\+ \ a :: Int\n\+ \, b :: !Double\n\+ \, c :: Maybe Rec\+ \\n\+ \}"+ ==>+ ["Rec", "Rec", "a", "b", "c"]++ , "data X = X !Int" ==> ["X", "X"]+ , "data X = Y !Int !X | Z" ==> ["X", "Y", "Z"]+ , "data X = Y :+: !Z | !X `Mult` X" ==> [":+:", "Mult", "X"]+ , "data X = !Y `Add` !Z" ==> ["Add", "X"]++ , "data X = forall a. Y a" ==> ["X", "Y"]+ , "data X = forall a . Y a" ==> ["X", "Y"]+ , "data X = forall a .Y a" ==> ["X", "Y"]+ , "data X = forall a.Y a" ==> ["X", "Y"]+ , "data X = forall a. Eq a => Y a" ==> ["X", "Y"]+ , "data X = forall a. (Eq a) => Y a" ==> ["X", "Y"]+ , "data X = forall a. (Eq a, Ord a) => Y a" ==> ["X", "Y"]+ -- "data X = forall a. Ref :<: a => Y a" ==> ["X", "Y"]+ -- "data X = forall a. (:<:) Ref a => Y a" ==> ["X", "Y"]+ , "data X = forall a. ((:<:) Ref a) => Y a" ==> ["X", "Y"]+ , "data X = forall a. Y !a" ==> ["X", "Y"]+ , "data X = forall a. (Eq a, Ord a) => Y !a" ==> ["X", "Y"]++ , "data Foo a = \n\+ \ Plain Int\n\+ \ | forall a. Bar a Int\n\+ \ | forall a b. Baz b a\n\+ \ | forall a . Quux a \+ \ | forall a .Quuz a"+ ==>+ ["Bar", "Baz", "Foo", "Plain", "Quux", "Quuz"]++ , "data X a = Add a " ==> ["Add", "X"]+ , "data Eq a => X a = Add a" ==> ["Add", "X"]+ , "data (Eq a) => X a = Add a" ==> ["Add", "X"]+ , "data (Eq a, Ord a) => X a = Add a" ==> ["Add", "X"]+ , "data (Eq (a), Ord (a)) => X a = Add a" ==> ["Add", "X"]++ -- These are hard-to-deal-with uses of contexts, which are probably not that+ -- common and therefoce can be ignored.+ -- "data Ref :<: f => X f = RRef f" ==> ["X", "RRef"]+ -- "data a :<: b => X a b = Add a" ==> ["X", "Add"]+ , "data (a :<: b) => X a b = Add a" ==> ["Add", "X"]++ , "newtype Eq a => X a = Add a" ==> ["Add", "X"]+ , "newtype (Eq a) => X a = Add a" ==> ["Add", "X"]+ , "newtype (Eq a, Ord a) => X a = Add a" ==> ["Add", "X"]++ , "newtype (u :*: v) z = X" ==> [":*:", "X"]+ , "data (u :*: v) z = X" ==> [":*:", "X"]+ , "type (u :*: v) z = (u, v, z)" ==> [":*:"]++ , "newtype ((u :: (* -> *) -> *) :*: v) z = X" ==> [":*:", "X"]+ , "data ((u :: (* -> *) -> *) :*: v) z = X" ==> [":*:", "X"]+ , "type ((u :: (* -> *) -> *) :*: v) z = (u, v, z)" ==> [":*:"]++ , "newtype (Eq (v z)) => ((u :: (* -> *) -> *) :*: v) z = X" ==> [":*:", "X"]+ , "data (Eq (v z)) => ((u :: (* -> *) -> *) :*: v) z = X" ==> [":*:", "X"]+ , "type (Eq (v z)) => ((u :: (* -> *) -> *) :*: v) z = (u, v, z)" ==> [":*:"]++ , "newtype Eq (v z) => ((u :: (* -> *) -> *) :*: v) z = X" ==> [":*:", "X"]+ , "data Eq (v z) => ((u :: (* -> *) -> *) :*: v) z = X" ==> [":*:", "X"]+ , "type Eq (v z) => ((u :: (* -> *) -> *) :*: v) z = (u, v, z)" ==> [":*:"]++ , "newtype (Eq (v z)) => ((u :: (* -> *) -> *) `Foo` v) z = X" ==> ["Foo", "X"]+ , "data (Eq (v z)) => ((u :: (* -> *) -> *) `Foo` v) z = X" ==> ["Foo", "X"]+ , "type (Eq (v z)) => ((u :: (* -> *) -> *) `Foo` v) z = (u, v, z)" ==> ["Foo"]++ , "newtype Eq (v z) => ((u :: (* -> *) -> *) `Foo` v) z = X" ==> ["Foo", "X"]+ , "data Eq (v z) => ((u :: (* -> *) -> *) `Foo` v) z = X" ==> ["Foo", "X"]+ , "type Eq (v z) => ((u :: (* -> *) -> *) `Foo` v) z = (u, v, z)" ==> ["Foo"]++ , "data (:*:) u v z = X" ==> [":*:", "X"]+ , "data (Eq (u v), Ord (z)) => (:*:) u v z = X" ==> [":*:", "X"]+ , "data (u `W` v) z = X" ==> ["W", "X"]+ , "data (Eq (u v), Ord (z)) => (u `W` v) z = X" ==> ["W", "X"]++ , "newtype X a = Z {\n\+ \ -- TODO blah\n\+ \ foo :: [a] }"+ ==>+ ["X", "Z", "foo"]+ , "newtype (u :*: v) z = X {\n\+ \ -- my insightful comment\n\+ \ extract :: (u (v z)) }"+ ==>+ [":*:", "X", "extract"]++ , "data Hadron a b = Science { f :: a, g :: a, h :: b }"+ ==>+ ["Hadron", "Science", "f", "g", "h"]+ , "data Hadron a b = Science { f :: a, g :: (a, b), h :: b }"+ ==>+ ["Hadron", "Science", "f", "g", "h"]+ , "data Hadron a b = forall x. Science { f :: x, h :: b }"+ ==>+ ["Hadron", "Science", "f", "h"]+ , "data Hadron a b = forall x. Science { f :: [x], h :: b }"+ ==>+ ["Hadron", "Science", "f", "h"]+ , "data Hadron a b = forall x y. Science { f :: (x, y), h :: b }"+ ==>+ ["Hadron", "Science", "f", "h"]+ , "data Hadron a b = forall x y. Science { f :: [(x, y)], h :: b }"+ ==>+ ["Hadron", "Science", "f", "h"]+ , "data Hadron a b = forall x y. Science { f :: [(Box x, Map x y)], h :: b }"+ ==>+ ["Hadron", "Science", "f", "h"]+ , "data Hadron a b = forall x y z. Science\n\+ \ { f :: x\n\+ \ , g :: [(Box x, Map x y, z)] \+ \ }"+ ==>+ ["Hadron", "Science", "f", "g"]+ , "data Hadron a b = forall x y z. Science\n\+ \ { f :: x\n\+ \ , g :: [(Box x, Map x y, z)] \+ \ , h :: b\n\+ \ }"+ ==>+ ["Hadron", "Science", "f", "g", "h"]+ , "data Hadron a b = Science { h :: b }"+ ==>+ ["Hadron", "Science", "h"]+ , "data Test a b =\n\+ \ Foo a\n\+ \ | Bar [(Maybe a, Map a b, b)]"+ ==>+ ["Bar", "Foo", "Test"]+ , "data Test a b =\n\+ \ Foo a\n\+ \ | [(Maybe b, Map b a, a)] `Bar` [(Maybe a, Map a b, b)]"+ ==>+ ["Bar", "Foo", "Test"]+ ]+ where+ (==>) = test process++testGADT :: TestTree+testGADT = testGroup "gadt"+ [ "data X where A :: X\n" ==> ["A", "X"]+ , "data X where\n\tA :: X\n" ==> ["A", "X"]+ , "data X where\n\tA :: X\n\tB :: X\n" ==> ["A", "B", "X"]+ , "data X where\n\tA, B :: X\n" ==> ["A", "B", "X"]+ , "data X :: * -> * -> * where\n\+ \ A, B :: Int -> Int -> X\n"+ ==>+ ["A", "B", "X"]+ , "data Vec ix where\n\+ \ Nil :: Int -> Foo Int\n\+ \ (:::) :: Int -> Vec Int -> Vec Int\n\+ \ (.+.) :: Int -> Int -> Vec Int -> Vec Int\n"+ ==>+ [".+.", ":::", "Nil", "Vec"]+ , "data Vec ix where\n\+ \ Nil :: Int -> Foo Int\n\+ \ -- foo\n\+ \ (:::) :: Int -> Vec Int -> Vec Int\n\+ \-- bar\n\+ \ (.+.) :: Int -> \n\+ \ -- ^ baz\n\+ \ Int -> \n\+ \ Vec Int -> \n\+ \Vec Int\n"+ ==>+ [".+.", ":::", "Nil", "Vec"]+ , "data NatSing (n :: Nat) where\n ZeroSing :: 'Zero\n SuccSing :: NatSing n -> NatSing ('Succ n)\n"+ ==>+ ["NatSing", "SuccSing", "ZeroSing"]+ ]+ where+ (==>) = test process++testFamilies :: TestTree+testFamilies = testGroup "families"+ [ "type family X :: *\n" ==> ["X"]+ , "data family X :: * -> *\n" ==> ["X"]+ , "data family a ** b" ==> ["**"]++ , "type family a :<: b\n" ==> [":<:"]+ , "type family (a :: Nat) :<: (b :: Nat) :: Nat\n" ==> [":<:"]+ , "type family (a :: Nat) `Family` (b :: Nat) :: Nat\n" ==> ["Family"]+ , "type family (m :: Nat) <=? (n :: Nat) :: Bool" ==> ["<=?"]++ , "data instance X a b = Y a | Z { unZ :: b }" ==> ["Y", "Z", "unZ"]+ , "data instance (Eq a, Eq b) => X a b = Y a | Z { unZ :: b }" ==> ["Y", "Z", "unZ"]+ , "data instance XList Char = XCons !Char !(XList Char) | XNil" ==> ["XCons", "XNil"]+ , "newtype instance Cxt x => T [x] = A (B x) deriving (Z,W)" ==> ["A"]+ , "data instance G [a] b where\n\+ \ G1 :: c -> G [Int] b\n\+ \ G2 :: G [a] Bool"+ ==>+ ["G1", "G2"]+ , "class C where\n\ttype X y :: *\n" ==> ["C", "X"]+ , "class C where\n\tdata X y :: *\n" ==> ["C", "X"]+ ]+ where+ (==>) = test process++testFunctions :: TestTree+testFunctions = testGroup "functions"+ [+ -- Multiple declarations.+ "a,b::X" ==> ["a", "b"]+ -- With an operator.+ , "(+), a :: X" ==> ["+", "a"]+ -- Don't get fooled by literals.+ , "1 :: Int" ==> []++ -- plain functions and operators+ , "(.::) :: X -> Y" ==> [".::"]+ , "(:::) :: X -> Y" ==> [":::"]+ , "(->:) :: X -> Y" ==> ["->:"]+ , "(--+) :: X -> Y" ==> ["--+"]+ , "(=>>) :: X -> Y" ==> ["=>>"]++ , "_g :: X -> Y" ==> ["_g"]+ , toplevelFunctionsWithoutSignatures+ ]+ where+ (==>) = test process+ toplevelFunctionsWithoutSignatures =+ testGroup "toplevel functions without signatures"+ [ "infix 5 |+|" ==> []+ , "infixl 5 |+|" ==> []+ , "infixr 5 |+|" ==> []+ , "f = g" ==> ["f"]+ , "f :: a -> b -> a\n\+ \f x y = x"+ ==>+ ["f"]+ , "f x y = x" ==> ["f"]+ , "f (x :+: y) z = x" ==> ["f"]+ , "(x :+: y) `f` z = x" ==> ["f"]+ , "(x :+: y) :*: z = x" ==> [":*:"]+ , "((:+:) x y) :*: z = x" ==> [":*:"]+ , "(:*:) (x :+: y) z = x" ==> [":*:"]+ , "(:*:) ((:+:) x y) z = x" ==> [":*:"]+ , strictMatchTests+ , lazyMatchTests+ , atPatternsTests+ , "f x Nothing = x\n\+ \f x (Just y) = y"+ ==>+ ["f"]+ , "f x y = g x\n\+ \ where\n\+ \ g _ = y"+ ==>+ ["f"]+ , "x `f` y = x" ==> ["f"]+ , "(|+|) x y = x" ==> ["|+|"]+ , "x |+| y = x" ==> ["|+|"]+ , "(!) x y = x" ==> ["!"]+ , "--- my comment" ==> []+ ]+ strictMatchTests = testGroup "strict match (!)"+ [ "f !x y = x" ==> ["f"]+ , "f x !y = x" ==> ["f"]+ , "f !x !y = x" ==> ["f"]+ , "f ! x y = x" ==> ["f"]+ -- this one is a bit controversial but it seems to be the way ghc parses it+ , "f ! x = x" ==> ["f"]+ , "(:*:) !(x :+: y) z = x" ==> [":*:"]+ , "(:*:) !(!x :+: !y) !z = x" ==> [":*:"]+ , "(:*:) !((:+:) x y) z = x" ==> [":*:"]+ , "(:*:) !((:+:) !x !y) !z = x" ==> [":*:"]+ , "(!) :: a -> b -> a\n\+ \(!) x y = x"+ ==>+ ["!"]+ -- this is a degenerate case since even ghc treats ! here as+ -- a BangPatterns instead of operator+ , "x ! y = x" ==> ["x"]+ ]+ lazyMatchTests = testGroup "lazy match (~)"+ [ "f ~x y = x" ==> ["f"]+ , "f x ~y = x" ==> ["f"]+ , "f ~x ~y = x" ==> ["f"]+ , "f ~ x y = x" ==> ["f"]+ -- this one is a bit controversial but it seems to be the way ghc parses it+ , "f ~ x = x" ==> ["f"]+ , "(:*:) ~(x :+: y) z = x" ==> [":*:"]+ , "(:*:) ~(~x :+: ~y) ~z = x" ==> [":*:"]+ , "(:*:) ~((:+:) x y) z = x" ==> [":*:"]+ , "(:*:) ~((:+:) ~x ~y) ~z = x" ==> [":*:"]+ , "(~) :: a -> b -> a\n\+ \(~) x y = x"+ ==>+ ["~"]+ -- this is a degenerate case since even ghc treats ~ here as+ -- a BangPatterns instead of operator+ , "x ~ y = x" ==> ["x"]+ ]+ atPatternsTests = testGroup "at patterns (@)"+ [ "f z@x y = z" ==> ["f"]+ , "f x z'@y = z'" ==> ["f"]+ , "f z@x z'@y = z" ==> ["f"]+ , "f z@(Foo _) z'@y = z" ==> ["f"]+ , "f z@(Foo _) z'@(Bar _) = z" ==> ["f"]+ , "f z @ x y = z" ==> ["f"]+ , "f z @ (x : xs) = z: [x: xs]" ==> ["f"]+ , "f z @ (x : zs @ xs) = z: [x: zs]" ==> ["f"]+ , "f z @ (zz @x : zs @ xs) = z: [zz: zs]" ==> ["f"]++ , "(:*:) zzz@(x :+: y) z = x" ==> [":*:"]+ , "(:*:) zzz@(zx@x :+: zy@y) zz@z = x" ==> [":*:"]+ , "(:*:) zzz@((:+:) x y) z = x" ==> [":*:"]+ , "(:*:) zzz@((:+:) zs@x zs@y) zz@z = x" ==> [":*:"]++ , "f z@(!x) ~y = x" ==> ["f"]+ ]++testClass :: TestTree+testClass = testGroup "class"+ [ "class (X x) => C a b where\n\tm :: a->b\n\tn :: c\n" ==> ["C", "m", "n"]+ , "class A a where f :: X\n" ==> ["A", "f"]+ -- indented inside where+ , "class X where\n\ta, (+) :: X\n" ==> ["+", "X", "a"]+ , "class X where\n\ta :: X\n\tb, c :: Y" ==> ["X", "a", "b", "c"]+ , "class X\n\twhere\n\ta :: X\n\tb, c :: Y" ==> ["X", "a", "b", "c"]+ , "class X\n\twhere\n\ta ::\n\t\tX\n\tb :: Y" ==> ["X", "a", "b"]++ , "class a :<: b where\n f :: a -> b" ==> [":<:", "f"]+ , "class (:<:) a b where\n f :: a -> b" ==> [":<:", "f"]+ , "class Eq a => a :<: b where\n f :: a -> b" ==> [":<:", "f"]+ -- , "class a :<<<: b => a :<: b where\n f :: a -> b"+ -- ==>+ -- [":<:", "f"]+ , "class (a :<<<: b) => a :<: b where\n f :: a -> b" ==> [":<:", "f"]+ , "class (Eq a, Ord b) => a :<: b where\n f :: a -> b" ==> [":<:", "f"]+ , "class (Eq a, Ord b) => (a :: (* -> *) -> *) :<: b where\n f :: a -> b"+ ==>+ [":<:", "f"]+ -- this is bizzarre+ , "class (Eq (a), Ord (f a [a])) => f `Z` a" ==> ["Z"]++ , "class A f where\n data F f :: *\n g :: a -> f a\n h :: f a -> a"+ ==>+ ["A", "F", "g", "h"]+ , "class A f where\n data F f :: *\n mkF :: f -> F f\n getF :: F f -> f"+ ==>+ ["A", "F", "getF", "mkF"]+ , "class A f where\n\+ \ data F f :: * -- foo\n\+ \ -- bar\n\+ \ -- baz\n\+ \ mkF :: f -> F f\n\+ \ getF :: F f -> f"+ ==>+ ["A", "F", "getF", "mkF"]+ -- Not confused by a class context on a method.+ , "class X a where\n\tfoo :: Eq a => a -> a\n" ==> ["X", "foo"]+ ]+ where+ (==>) = test process++testInstance :: TestTree+testInstance = testGroup "instance"+ [ "instance Foo Quux where\n\+ \ data Bar Quux a = QBar { frob :: a }\n\+ \ | QBaz { fizz :: String }\n\+ \ deriving (Show)"+ ==>+ ["QBar", "QBaz", "fizz", "frob"]+ , "instance Foo Quux where\n\+ \ data Bar Quux a = QBar a | QBaz String deriving (Show)"+ ==>+ ["QBar", "QBaz"]+ , "instance Foo Quux where\n\+ \ data Bar Quux a = QBar { frob :: a }\n\+ \ | QBaz { fizz :: String }\n\+ \ deriving (Show)\n\+ \ data IMRuunningOutOfNamesHere Quux = Whatever"+ ==>+ ["QBar", "QBaz", "Whatever", "fizz", "frob"]+ -- in this test foo function should not affect tags found+ , "instance Foo Quux where\n\+ \ data Bar Quux a = QBar { frob :: a }\n\+ \ | QBaz { fizz :: String }\n\+ \ deriving (Show)\n\+ \\n\+ \ foo _ = QBaz \"hey there\""+ ==>+ ["QBar", "QBaz", "fizz", "frob"]+ , "instance Foo Int where foo _ = 1"+ ==>+ []+ , "instance Foo Quux where\n\+ \ newtype Bar Quux a = QBar a \n\+ \ deriving (Show)\n\+ \\n\+ \ foo _ = QBaz \"hey there\""+ ==>+ ["QBar"]+ , "instance Foo Quux where\n\+ \ newtype Bar Quux a = QBar { frob :: a }"+ ==>+ ["QBar", "frob"]+ ]+ where+ (==>) = test process++testLiterate :: TestTree+testLiterate = testGroup "literate"+ [ "> class (X x) => C a b where\n>\tm :: a->b\n>\tn :: c\n"+ ==>+ ["C", "m", "n"]+ , "Test\n\\begin{code}\nclass (X x) => C a b where\n\tm :: a->b\n\tn :: c\n\\end{code}"+ ==>+ ["C", "m", "n"]+ ]+ where+ (==>) = test f+ f = map untag . fst . FastTags.process "fn.lhs" False++testPatterns :: TestTree+testPatterns = testGroup "patterns"+ [ "pattern Arrow a b = ConsT \"->\" [a, b]"+ ==>+ ["Arrow"]+ , "pattern Arrow a b = ConsT \"->\" [a, b]\n\+ \pattern Pair a b = [a, b]"+ ==>+ ["Arrow", "Pair"]+ ]+ where+ (==>) = test process++testFFI :: TestTree+testFFI = testGroup "ffi"+ [ "foreign import ccall foo :: Double -> IO Double" ==> ["foo"]+ , "foreign import unsafe java foo :: Double -> IO Double" ==> ["foo"]+ , "foreign import safe stdcall foo :: Double -> IO Double" ==> ["foo"]+ ]+ where+ (==>) = test process++process :: Text -> [String]+process = map untag . fst . FastTags.process "fn.hs" False++untag :: Pos TagVal -> String+untag (Pos _ (TagVal _ name _)) = T.unpack name++tokenize :: Text -> UnstrippedTokens+tokenize =+ Monoid.mconcat . map (FastTags.tokenize False) . FastTags.stripCpp . FastTags.annotate "fn"++extractTokens :: UnstrippedTokens -> [Text]+extractTokens = map (\token -> case FastTags.valOf token of+ Token _ name -> name+ Newline n -> T.pack ("nl " ++ show n)) . FastTags.unstrippedTokensOf