fast-tags 0.0.5 → 0.0.6
raw patch · 8 files changed
+543/−669 lines, 8 filesdep +ghc
Dependencies added: ghc
Files
- README +1/−5
- changelog.md +22/−0
- fast-tags.cabal +18/−22
- src/FastTags.hs +441/−0
- src/Main.hs +16/−438
- src/Main_test.hs +45/−26
- src/T.hs +0/−4
- src/mt.hs +0/−174
README view
@@ -3,10 +3,6 @@ TODO: -- Lots of files are not in UTF8. Use ByteString with a lenient decoder?+- Some files are not in UTF8. Use ByteString with a lenient decoder? - \ continuation in strings is not parsed correctly.--- Literate haskell.--- Entire module indented. But who does this?
+ changelog.md view
@@ -0,0 +1,22 @@+0.0.6:++* fix bug where class context in a class's methods would be confused for the+context of the class itself++0.0.5:++* Tags with the same name are sorted by their type: Function, Type,+Constructor, Class, Module.++0.0.4:++* Fixed bug that prevented old tags from being filtered out.++0.0.3:++* Lots of speed ups, especially when given lots of files at once.++* Support for type families and GADTs.++* Support infix operators, multiple declarations per line, and fix various+other bugs that missed or gave bad tags.
fast-tags.cabal view
@@ -1,5 +1,5 @@ name: fast-tags-version: 0.0.5+version: 0.0.6 cabal-version: >= 1.8 build-type: Simple synopsis: Fast incremental vi tags.@@ -11,27 +11,9 @@ 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. This only works for files changed be the+ keep the tags file up to date. This only works for files changed by 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 filtered out.- .- Changes since 0.0.2:- .- * Lots of speed ups, especially when given lots of files at once.- .- * Support for type families and GADTs.- .- * Support infix operators, multiple declarations per line, and fix various- other bugs that missed or gave bad tags.- . Limitations: . - No emacs tags, but they would be easy to add.@@ -51,11 +33,14 @@ license-file: LICENSE author: Evan Laforge maintainer: Evan Laforge <qdunkan@gmail.com>-stability: experimental+stability: stable tested-with: GHC>=7.0.3 data-files: README-extra-source-files: src/*.hs+extra-source-files:+ changelog.md+ src/*.hs +homepage: https://github.com/elaforge/fast-tags source-repository head type: git location: git://github.com/elaforge/fast-tags.git@@ -67,3 +52,14 @@ -- text 0.11.1.12 has a bug. text (> 0.11.1.12 || < 0.11.1.12) ghc-options: -Wall -fno-warn-name-shadowing++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: src+ main-is: Main_test.hs+ build-depends: ghc,+ base >= 3 && < 5, containers,+ -- 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
+ src/FastTags.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE OverloadedStrings, PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+module FastTags where+import qualified Control.Exception as Exception+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 Data.Text (Text)+import qualified Data.Text.IO as Text.IO++import qualified Debug.Trace as Trace+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++-- | 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.Set Text -> Text -> Bool+isNewTag textFns line = Set.member fn textFns+ where fn = T.takeWhile (/='\t') $ T.drop 1 $ T.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) (Tag text typ)) =+ T.concat [text, "\t", T.pack fn, "\t", T.pack (show lineno), " ;\" ",+ T.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'++-- * types++data TagVal = Tag !Text !Type+ deriving (Eq, Show)++data Type = Module | Function | Class | Type | Constructor+ deriving (Eq, Show)++data TokenVal = Token !Text | Newline !Int+ deriving (Eq, Show)++type Tag = Either String (Pos TagVal)+type Token = Pos TokenVal++-- | Newlines have to remain in the tokens because 'breakBlocks' relies on+-- them. But they make pattern matching on the tokens unreliable because+-- 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)++mapTokens :: ([Token] -> [Token]) -> UnstrippedTokens -> UnstrippedTokens+mapTokens f (UnstrippedTokens tokens) = UnstrippedTokens (f tokens)++unstrippedTokensOf :: UnstrippedTokens -> [Token]+unstrippedTokensOf (UnstrippedTokens tokens) = tokens++type Line = Pos Text++data Pos a = Pos {+ posOf :: !SrcPos+ , valOf :: !a+ }++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+ -- 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 []++-- | Process one file's worth of tags.+process :: FilePath -> Text -> [Tag]+process fn = concatMap blockTags . breakBlocks . stripComments+ . Monoid.mconcat . map tokenize . stripCpp . annotate fn++-- * tokenize++annotate :: FilePath -> Text -> [Line]+annotate fn text =+ [Pos (SrcPos fn num) line | (num, line) <- zip [1..] (T.lines text)]++-- | Also strips out hsc detritus.+stripCpp :: [Line] -> [Line]+stripCpp = filter $ not . ("#" `T.isPrefixOf`) . valOf++tokenize :: Line -> UnstrippedTokens+tokenize (Pos pos line) = UnstrippedTokens $ map (Pos pos) (tokenizeLine line)++tokenizeLine :: Text -> [TokenVal]+tokenizeLine text = Newline nspaces : go line+ where+ nspaces = 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++startIdentChar :: Char -> Bool+startIdentChar c = Char.isAlpha c || c == '_'++identChar :: Char -> Bool+identChar c = Char.isAlphaNum c || c == '.' || c == '\'' || c == '_'++-- | Span a symbol, making sure to not eat comments.+spanSymbol :: Text -> (Text, Text)+spanSymbol text+ | any (`T.isPrefixOf` post) [",", "--", "-}", "{-"] = (pre, post)+ | Just (c, cs) <- T.uncons post, c == '-' || c == '{' =+ let (pre2, post2) = spanSymbol cs+ in (pre <> T.cons c pre2, post2)+ | otherwise = (pre, post)+ where+ (pre, post) = T.break (\c -> T.any (==c) "-{," || not (symbolChar c)) text++symbolChar :: Char -> Bool+symbolChar c = Char.isSymbol c || Char.isPunctuation c++breakChar :: Text -> (Text, Text)+breakChar text+ | T.null text = ("", "")+ | T.head text == '\\' = T.splitAt 3 text+ | otherwise = 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 == '"'++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++-- | Break the input up into blocks based on indentation.+breakBlocks :: UnstrippedTokens -> [UnstrippedTokens]+breakBlocks = map UnstrippedTokens . filter (not . null) . go . filterBlank+ . unstrippedTokensOf+ where+ go [] = []+ go tokens = pre : go post+ where (pre, post) = breakBlock tokens+ -- Blank lines mess up the indentation.+ 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.+breakBlock :: [Token] -> ([Token], [Token])+breakBlock (t@(Pos _ tok):ts) = case tok of+ Newline indent -> collectIndented indent ts+ _ -> let (pre, post) = breakBlock ts in (t:pre, post)+ 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 _ [] = ([], [])+breakBlock [] = ([], [])+++-- * extract tags++-- | Get all the tags in one indented block.+blockTags :: UnstrippedTokens -> [Tag]+blockTags tokens = case stripNewlines tokens of+ [] -> []+ Pos _ (Token "module") : Pos pos (Token name) : _ ->+ [mktag pos (snd (T.breakOnEnd "." name)) Module]+ -- newtype X * = X *+ Pos _ (Token "newtype") : Pos pos (Token name) : rest ->+ mktag pos name Type : newtypeTags pos rest+ -- type family X ...+ Pos _ (Token "type") : Pos _ (Token "family") : Pos pos (Token name) : _ ->+ [mktag pos name Type]+ -- type X * = ...+ Pos _ (Token "type") : Pos pos (Token name) : _ -> [mktag pos name Type]+ -- data family X ...+ Pos _ (Token "data") : Pos _ (Token "family") : Pos pos (Token name) : _ ->+ [mktag pos name Type]+ -- 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)+ -- class * => X where X :: * ...+ Pos pos (Token "class") : _ -> classTags pos (mapTokens (drop 1) tokens)+ -- x, y, z :: *+ stripped -> fst $ functionTags False stripped++-- | 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)++-- | 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+ 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+ 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++-- | * = X *+newtypeTags :: SrcPos -> [Token] -> [Tag]+newtypeTags prevPos tokens = case dropUntil "=" tokens of+ Pos pos (Token name) : _ -> [mktag pos name 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) =+ concatMap gadtTags (whereBlock unstripped)+ | otherwise = case dropUntil "=" (stripNewlines unstripped) of+ [] -> [] -- empty data declaration+ Pos pos (Token name) : rest ->+ mktag pos name Constructor : collectRest rest+ rest -> unexpected prevPos unstripped rest "data * ="+ where+ collectRest tokens+ | (tags@(_:_), rest) <- functionTags False tokens =+ tags ++ collectRest rest+ collectRest (Pos _ (Token "|") : Pos pos (Token name) : rest) =+ mktag pos name Constructor : collectRest rest+ collectRest (_ : rest) = collectRest rest+ collectRest [] = []++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++classBodyTags :: UnstrippedTokens -> [Tag]+classBodyTags unstripped = case stripNewlines unstripped of+ Pos _ (Token typedata) : Pos pos (Token name) : _+ | typedata `elem` ["type", "data"] -> [mktag pos 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")+++-- * util++mktag :: SrcPos -> Text -> Type -> Tag+mktag pos name typ = Right $ Pos pos (Tag name typ)++warning :: SrcPos -> String -> Tag+warning pos warn = Left $ 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))+ pos+ | not (null tokensHere) = posOf (head tokensHere)+ | not (null tokensBefore) = posOf (last tokensBefore)+ | otherwise = prevPos++dropLine :: [Token] -> [Token]+dropLine = drop 1 . dropWhile (not . isNewline)++isNewline :: Token -> Bool+isNewline (Pos _ (Newline _)) = True+isNewline _ = False++-- | Drop until a token, then drop that token.+dropUntil :: Text -> [Token] -> [Token]+dropUntil token = drop 1 . dropWhile ((/= Token token) . valOf)++-- | Take until, but not including, a token.+takeUntil :: Text -> [Token] -> [Token]+takeUntil token = takeWhile ((/= Token token) . valOf)+++-- * misc++tracem :: Show a => String -> a -> a+tracem msg x = Trace.trace (msg ++ ": " ++ show x) x++-- | 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)++dropDups :: Eq k => (a -> k) -> [a] -> [a]+dropDups key (x:xs) = go x xs+ where+ go a [] = [a]+ go a (b:bs)+ | 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))++-- | Merge sorted lists.+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
src/Main.hs view
@@ -1,43 +1,37 @@-{-# LANGUAGE OverloadedStrings, PatternGuards, ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# LANGUAGE ScopedTypeVariables #-} {- | Tagify haskell source. - Annotate lines, strip comments, tokenize, then search for- It loads the existing tags, and updates it for the given file. Then- a SaveBuf action runs tags every time you save a file.- Or extend lushtags, the question is complete parsing ok? It means I can't- do it on save, since I'd have to invoke the build system to de-hsc.+ The key features are to be fast, incremental (i.e. merge tags with one+ file into existing tags), work on partially edited code, and work with+ hsc. That way I can hook it to the editor's save action and always keep+ the tags up to date. -} module Main where-import qualified Control.Exception as Exception import Control.Monad-import qualified Data.Char as Char import qualified Data.Either as Either import qualified Data.List as List-import qualified Data.Monoid as Monoid-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text (Text)+import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO -import qualified Debug.Trace as Trace import qualified System.Console.GetOpt as GetOpt import qualified System.Environment as Environment import qualified System.Exit import qualified System.IO as IO-import qualified System.IO.Error as IO.Error +import FastTags + main :: IO () main = do args <- Environment.getArgs (flags, inputs) <- case GetOpt.getOpt GetOpt.Permute options args of (flags, inputs, []) -> return (flags, inputs) (_, _, errs) -> usage $ "flag errors:\n" ++ List.intercalate ", " errs+ when (null inputs) $+ usage "no input files\n" let output = last $ "tags" : [fn | Output fn <- flags] verbose = Verbose `elem` flags- oldTags <- fmap (maybe [vimMagicLine] T.lines) $+ oldTags <- fmap (maybe [vimMagicLine] Text.lines) $ catchENOENT $ Text.IO.readFile output -- 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@@ -62,17 +56,12 @@ let write = if output == "-" then Text.IO.hPutStr IO.stdout else Text.IO.writeFile output- write $ T.unlines (mergeTags inputs oldTags newTags)+ write $ Text.unlines (mergeTags inputs oldTags newTags) where- usage msg = putStr (GetOpt.usageInfo msg options)- >> System.Exit.exitSuccess--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+ usage msg = do+ putStr $ GetOpt.usageInfo+ (msg ++ "\nusage: fast-tags file1 file2 ...") options+ System.Exit.exitFailure data Flag = Output FilePath | Verbose deriving (Eq, Show)@@ -84,414 +73,3 @@ , GetOpt.Option ['v'] [] (GetOpt.NoArg Verbose) "print files as they are tagged, useful to track down slow 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.Set Text -> Text -> Bool-isNewTag textFns line = Set.member fn textFns- where fn = T.takeWhile (/='\t') $ T.drop 1 $ T.dropWhile (/='\t') line--merge :: [Text] -> [Text] -> [Text]-merge [] ys = ys-merge xs [] = xs-merge (x:xs) (y:ys)- | x <= y = x : merge xs (y:ys)- | otherwise = y : merge (x:xs) ys----- | 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)]---- | 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'---- * types--data TagVal = Tag !Text !Type- deriving (Eq, Show)--data Type = Module | Function | Class | Type | Constructor- deriving (Eq, Show)--data TokenVal = Token !Text | Newline !Int- deriving (Eq, Show)--type Tag = Either String (Pos TagVal)-type Token = Pos TokenVal---- | Newlines have to remain in the tokens because 'breakBlocks' relies on--- them. But they make pattern matching on the tokens unreliable because--- 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)--mapTokens :: ([Token] -> [Token]) -> UnstrippedTokens -> UnstrippedTokens-mapTokens f (UnstrippedTokens tokens) = UnstrippedTokens (f tokens)--unstrippedTokensOf :: UnstrippedTokens -> [Token]-unstrippedTokensOf (UnstrippedTokens tokens) = tokens--type Line = Pos Text--data Pos a = Pos {- posOf :: !SrcPos- , valOf :: !a- }--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- -- 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 []---- | Process one file's worth of tags.-process :: FilePath -> Text -> [Tag]-process fn = concatMap blockTags . breakBlocks . stripComments- . Monoid.mconcat . map tokenize . stripCpp . annotate fn---- * tokenize--annotate :: FilePath -> Text -> [Line]-annotate fn text =- [Pos (SrcPos fn num) line | (num, line) <- zip [1..] (T.lines text)]---- | Also strips out hsc detritus.-stripCpp :: [Line] -> [Line]-stripCpp = filter $ not . ("#" `T.isPrefixOf`) . valOf--tokenize :: Line -> UnstrippedTokens-tokenize (Pos pos line) = UnstrippedTokens $ map (Pos pos) (tokenizeLine line)--tokenizeLine :: Text -> [TokenVal]-tokenizeLine text = Newline nspaces : go line- where- nspaces = 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--startIdentChar :: Char -> Bool-startIdentChar c = Char.isAlpha c || c == '_'--identChar :: Char -> Bool-identChar c = Char.isAlphaNum c || c == '.' || c == '\'' || c == '_'---- | Span a symbol, making sure to not eat comments.-spanSymbol :: Text -> (Text, Text)-spanSymbol text- | any (`T.isPrefixOf` post) [",", "--", "-}", "{-"] = (pre, post)- | Just (c, cs) <- T.uncons post, c == '-' || c == '{' =- let (pre2, post2) = spanSymbol cs- in (pre <> T.cons c pre2, post2)- | otherwise = (pre, post)- where- (pre, post) = T.break (\c -> T.any (==c) "-{," || not (symbolChar c)) text--symbolChar :: Char -> Bool-symbolChar c = Char.isSymbol c || Char.isPunctuation c--breakChar :: Text -> (Text, Text)-breakChar text- | T.null text = ("", "")- | T.head text == '\\' = T.splitAt 3 text- | otherwise = 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 == '"'--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---- | Break the input up into blocks based on indentation.-breakBlocks :: UnstrippedTokens -> [UnstrippedTokens]-breakBlocks = map UnstrippedTokens . filter (not . null) . go . filterBlank- . unstrippedTokensOf- where- go [] = []- go tokens = pre : go post- where (pre, post) = breakBlock tokens- -- Blank lines mess up the indentation.- 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.-breakBlock :: [Token] -> ([Token], [Token])-breakBlock (t@(Pos _ tok):ts) = case tok of- Newline indent -> collectIndented indent ts- _ -> let (pre, post) = breakBlock ts in (t:pre, post)- 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 _ [] = ([], [])-breakBlock [] = ([], [])----- * extract tags---- | Get all the tags in one indented block.-blockTags :: UnstrippedTokens -> [Tag]-blockTags tokens = case stripNewlines tokens of- [] -> []- Pos _ (Token "module") : Pos pos (Token name) : _ ->- [mktag pos (snd (T.breakOnEnd "." name)) Module]- -- newtype X * = X *- Pos _ (Token "newtype") : Pos pos (Token name) : rest ->- mktag pos name Type : newtypeTags pos rest- -- type family X ...- Pos _ (Token "type") : Pos _ (Token "family") : Pos pos (Token name) : _ ->- [mktag pos name Type]- -- type X * = ...- Pos _ (Token "type") : Pos pos (Token name) : _ -> [mktag pos name Type]- -- data family X ...- Pos _ (Token "data") : Pos _ (Token "family") : Pos pos (Token name) : _ ->- [mktag pos name Type]- -- 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)- -- class * => X where X :: * ...- Pos pos (Token "class") : _ -> classTags pos (mapTokens (drop 1) tokens)- -- x, y, z :: *- stripped -> fst $ functionTags False stripped---- | 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)---- | 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- 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- 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---- | * = X *-newtypeTags :: SrcPos -> [Token] -> [Tag]-newtypeTags prevPos tokens = case dropUntil "=" tokens of- Pos pos (Token name) : _ -> [mktag pos name 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) =- concatMap gadtTags (whereBlock unstripped)- | otherwise = case dropUntil "=" (stripNewlines unstripped) of- [] -> [] -- empty data declaration- Pos pos (Token name) : rest ->- mktag pos name Constructor : collectRest rest- rest -> unexpected prevPos unstripped rest "data * ="- where- collectRest tokens- | (tags@(_:_), rest) <- functionTags False tokens =- tags ++ collectRest rest- collectRest (Pos _ (Token "|") : Pos pos (Token name) : rest) =- mktag pos name Constructor : collectRest rest- collectRest (_ : rest) = collectRest rest- collectRest [] = []--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 = if any ((== Token "=>") . valOf) tokens- then dropUntil "=>" tokens else tokens--classBodyTags :: UnstrippedTokens -> [Tag]-classBodyTags unstripped = case stripNewlines unstripped of- Pos _ (Token typedata) : Pos pos (Token name) : _- | typedata `elem` ["type", "data"] -> [mktag pos 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")----- * util--mktag :: SrcPos -> Text -> Type -> Tag-mktag pos name typ = Right $ Pos pos (Tag name typ)--warning :: SrcPos -> String -> Tag-warning pos warn = Left $ 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))- pos- | not (null tokensHere) = posOf (head tokensHere)- | not (null tokensBefore) = posOf (last tokensBefore)- | otherwise = prevPos--dropLine :: [Token] -> [Token]-dropLine = drop 1 . dropWhile (not . isNewline)--isNewline :: Token -> Bool-isNewline (Pos _ (Newline _)) = True-isNewline _ = False--dropUntil :: Text -> [Token] -> [Token]-dropUntil token = drop 1 . dropWhile ((/= Token token) . valOf)----- * misc--tracem :: (Show a) => String -> a -> a-tracem msg x = Trace.trace (msg ++ ": " ++ show x) x--(<>) :: (Monoid.Monoid a) => a -> a -> a-(<>) = Monoid.mappend---- | 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)--dropDups :: (Eq k) => (a -> k) -> [a] -> [a]-dropDups key (x:xs) = go x xs- where- go a [] = [a]- go a (b:bs)- | 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
@@ -1,25 +1,41 @@ {-# LANGUAGE OverloadedStrings #-}-module Main_test where+import qualified Control.Concurrent.MVar as MVar 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.Exit as Exit import qualified System.IO.Unsafe as Unsafe -import qualified Main as Main-import Main (TokenVal(..), TagVal(..), Type(..), Tag, Pos(..))+import qualified FastTags as FastTags+import FastTags (TokenVal(..), TagVal(..), Type(..), Tag, Pos(..)) +-- | Record number of failures so I can tell the caller about it. It would be+-- better to use a shell script and grep, but cabal test doesn't seem to+-- support that easily.+failures :: MVar.MVar Int+failures = Unsafe.unsafePerformIO (MVar.newMVar 0)+{-# NOINLINE failures #-}+ -- This is kind of annoying without automatic test_* collection...-main = sequence_- [ test_tokenize, test_skipString, test_stripComments- , test_breakBlocks, test_processAll- , test_process- ]+main :: IO ()+main = do+ sequence_+ [ test_tokenize, test_skipString, test_stripComments+ , test_breakBlocks, test_processAll+ , test_process+ ]+ exit =<< MVar.readMVar failures +exit :: Int -> IO a+exit 0 = Exit.exitSuccess+exit n = Exit.exitWith $ Exit.ExitFailure n+ test_tokenize = do -- drop leading "nl 0" let f = drop 1 . extractTokens . tokenize@@ -28,14 +44,13 @@ ["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+ let f = FastTags.skipString equal assert (f "hi \" there") " there" equal assert (f "hi \\a \" there") " there" equal assert (f "hi \\\" there\"") ""@@ -44,15 +59,16 @@ equal assert (f "hi \\") "" test_stripComments = do- let f = extractTokens . Main.stripComments . tokenize+ let f = extractTokens . FastTags.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+ let f = map+ (extractTokens . FastTags.UnstrippedTokens . FastTags.stripNewlines)+ . FastTags.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"]]@@ -64,8 +80,8 @@ 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)+ let f = map showTag . FastTags.processAll . Either.rights+ . concatMap (\(i, t) -> FastTags.process ("fn" ++ show i) t) . zip [0..] showTag (Pos p (Tag text typ)) = unwords [show p, Text.unpack text, show typ]@@ -84,7 +100,7 @@ ] test_misc = do- let f text = [tag | Right (Pos _ tag) <- Main.process "fn" text]+ let f text = [tag | Right (Pos _ tag) <- FastTags.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 "Foo" Type, Tag "Bar" Constructor]@@ -149,35 +165,38 @@ ["X", "a", "b", "c"] equal assert (f "class X\n\twhere\n\ta ::\n\t\tX\n\tb :: Y") ["X", "a", "b"]+ -- Not confused by a class context on a method.+ equal assert (f "class X a where\n\tfoo :: Eq a => a -> a\n")+ ["X", "foo"] process :: Text.Text -> [String]-process = map untag . Main.process "fn"+process = map untag . FastTags.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"+tokenize :: Text.Text -> FastTags.UnstrippedTokens+tokenize = Monoid.mconcat . map FastTags.tokenize . FastTags.stripCpp+ . FastTags.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+extractTokens :: FastTags.UnstrippedTokens -> [Text.Text]+extractTokens = map (\token -> case FastTags.valOf token of Token name -> name- Newline n -> Text.pack ("nl " ++ show n)) . Main.unstrippedTokensOf+ Newline n -> Text.pack ("nl " ++ show n)) . FastTags.unstrippedTokensOf equal :: (Show a, Eq a) => Assert z -> a -> a -> IO ()-equal srcpos x y = unless (x == y) $+equal srcpos x y = unless (x == y) $ do putStrLn $ "__ " ++ getSourceLoc srcpos ++ " " ++ show x ++ " /= " ++ show y+ MVar.modifyMVar_ failures (return . (+1)) 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.evaluate (assert_ False (error "srcloc hack failed")) `Exception.catch` (\(Exception.AssertionFailed s) -> return s)-
− src/T.hs
@@ -1,4 +0,0 @@-module T where--f :: X -> Y-f = id
− src/mt.hs
@@ -1,174 +0,0 @@-{-# 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)-