fast-tags 0.0.2 → 0.0.3
raw patch · 5 files changed
+416/−199 lines, 5 filesdep ~text
Dependency ranges changed: text
Files
- README +5/−6
- fast-tags.cabal +32/−10
- src/Main.hs +238/−131
- src/Main_test.hs +130/−52
- src/T.hs +11/−0
README view
@@ -1,13 +1,12 @@-See vimrc for an example of how to keep the tags file up to date automatically.--Design decisions:+See vimrc for an example of how to keep the tags file up to date+automatically. -- Only top-level functions with type declarations are tagged.+TODO: -Not supported:+- Lots of files are not in UTF8. Use ByteString with a lenient decoder? - \ continuation in strings is not parsed correctly. - Literate haskell. -- Infix operators.+- Entire module indented. But who does this?
fast-tags.cabal view
@@ -1,19 +1,40 @@ name: fast-tags-version: 0.0.2-cabal-version: >= 1.6+version: 0.0.3+cabal-version: >= 1.8 build-type: Simple synopsis: Fast incremental vi 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 should be even- faster than hasktags because it uses Text instead of String. It also- understands hsc files, though not literate haskell. It's also less buggy- than hasktags.+ than haskell-src or haskell-src-exts, so it's fast. It understands+ hsc files, though not literate haskell. . 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.+ .+ 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.+ .+ - Not using a real haskell parser means there are more 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. category: Haskell, Development license: BSD3@@ -26,12 +47,13 @@ extra-source-files: src/*.hs source-repository head- type: darcs- location: http://ofb.net/~elaforge/darcs/fast-tags/+ type: git+ location: git://github.com/elaforge/fast-tags.git executable fast-tags main-is: Main.hs hs-source-dirs: src- -- text 0.11.1.12 has a bug.- build-depends: base >= 3 && < 5, containers, text >= 0.11.1.13+ build-depends: base >= 3 && < 5, containers,+ -- text 0.11.1.12 has a bug.+ text (> 0.11.1.12 || < 0.11.1.12) ghc-options: -Wall -fno-warn-name-shadowing
src/Main.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE OverloadedStrings, PatternGuards #-}-{- |+{-# LANGUAGE OverloadedStrings, PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+{- | 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.@@ -13,10 +16,12 @@ 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.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@@ -31,28 +36,45 @@ (flags, inputs, []) -> return (flags, inputs) (_, _, errs) -> usage $ "flag errors:\n" ++ List.intercalate ", " errs let output = last $ "tags" : [fn | Output fn <- flags]+ verbose = Verbose `elem` flags oldTags <- fmap (maybe [vimMagicLine] T.lines) $ catchENOENT $ Text.IO.readFile output- tags <- fmap concat (mapM processFile inputs)+ newTags <- fmap concat $ forM (zip [0..] inputs) $ \(i :: Int, fn) -> do+ tags <- processFile fn+ -- This has the side-effect of forcing the the tags, which is essential+ -- if I'm tagging a lot of files at once.+ let (warnings, newTags) = Either.partitionEithers tags+ forM_ warnings $ \warn -> do+ IO.hPutStrLn IO.stderr warn+ when verbose $ do+ let line = show i ++ " of " ++ show (length inputs - 1)+ ++ ": " ++ fn+ putStr $ '\r' : line ++ replicate (78 - length line) ' '+ IO.hFlush IO.stdout+ return newTags+ when verbose $ putChar '\n' - let (warnings, newTags) = Either.partitionEithers $ map showTag tags- forM_ warnings $ \warn -> do- IO.hPutStrLn IO.stderr warn let write = if output == "-" then Text.IO.hPutStr IO.stdout else Text.IO.writeFile output- write $ T.unlines $- merge (List.sort newTags) (filter (not . isNewTag inputs) oldTags)++ -- Turns out GHC will not float out the T.pack and it makes a big+ -- performance difference.+ let textFns = Set.fromList $ map (T.pack . ('\t':)) inputs+ filtered = filter (not . isNewTag textFns) oldTags+ write $ T.unlines $ merge (List.sort (map showTag newTags)) filtered where usage msg = putStr (GetOpt.usageInfo msg options) >> System.Exit.exitSuccess -data Flag = Output FilePath- deriving (Show)+data Flag = Output FilePath | Verbose+ deriving (Eq, Show) options :: [GetOpt.OptDescr Flag] options = [ GetOpt.Option ['o'] [] (GetOpt.ReqArg Output "filename") "output file, defaults to 'tags'"+ , 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.@@ -61,9 +83,9 @@ vimMagicLine :: Text vimMagicLine = "!_TAG_FILE_SORTED\t1\t~" -isNewTag :: [FilePath] -> Text -> Bool-isNewTag fns line = any (`T.isInfixOf` line) textFns- where textFns = map (T.pack . ('\t':)) fns+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@@ -73,15 +95,15 @@ | otherwise = y : merge (x:xs) ys --- AbsoluteMark\tCmd/TimeStep.hs 67 ;" f--- TODO use "file:" for non-exported symbols, this should make vim search for--- them first within the file.-showTag :: Tag -> Either String Text-showTag (Pos (SrcPos fn lineno) (Tag text typ)) = Right $+-- | 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)]-showTag (Pos pos (Warning text)) = Left $ show pos ++ ": " ++ text +-- | 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'@@ -92,7 +114,7 @@ -- * types -data TagVal = Tag !Text !Type | Warning !String+data TagVal = Tag !Text !Type deriving (Eq, Show) data Type = Module | Function | Class | Type | Constructor@@ -101,13 +123,27 @@ data TokenVal = Token !Text | Newline !Int deriving (Eq, Show) -type Tag = Pos TagVal+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+ posOf :: !SrcPos+ , valOf :: !a } data SrcPos = SrcPos {@@ -122,14 +158,19 @@ 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 :: FilePath -> Text -> [Tag] process fn = dropDups tagText . concatMap blockTags . breakBlocks- . stripComments . concatMap tokenize . stripCpp . annotate fn+ . stripComments . Monoid.mconcat . map tokenize . stripCpp . annotate fn where- tagText (Pos _ (Tag text _)) = text- tagText (Pos _ (Warning warn)) = T.pack warn-+ tagText (Right (Pos _ (Tag text _))) = text+ tagText (Left warn) = T.pack warn -- * tokenize @@ -141,8 +182,8 @@ stripCpp :: [Line] -> [Line] stripCpp = filter $ not . ("#" `T.isPrefixOf`) . valOf -tokenize :: Line -> [Token]-tokenize (Pos pos line) = map (Pos pos) (tokenizeLine line)+tokenize :: Line -> UnstrippedTokens+tokenize (Pos pos line) = UnstrippedTokens $ map (Pos pos) (tokenizeLine line) tokenizeLine :: Text -> [TokenVal] tokenizeLine text = Newline nspaces : go line@@ -156,45 +197,61 @@ Token sym : go (T.drop (T.length sym) text) | c == '\'' = let (token, rest) = breakChar text in Token (T.cons c token) : go rest- | c == '"' = let (token, rest) = breakString cs- in Token (T.cons c token) : go rest- | Char.isSymbol c || Char.isPunctuation c =- Token (T.singleton c) : go cs- | otherwise =- let (token, rest) = T.span isIdent text in Token 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- isIdent c = Char.isAlphaNum c || c == '.' || c == '\'' || c == '_' +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 --- | Break after the ending double-quote of a string.+-- | 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.-breakString :: Text -> (Text, Text)-breakString text = case T.uncons post of- Nothing -> (text, "")- Just (c, cs)- | c == '\\' && T.null cs -> (T.snoc pre c, "")- | c == '\\' && T.head cs == '"' ->- let (pre', post') = breakString (T.tail cs)- in (pre <> "\\\"" <> pre', post')- | c == '\\' ->- let (pre', post') = breakString cs- in (T.snoc pre c <> pre', post')- | otherwise -> (T.snoc pre c, cs)- where- (pre, post) = T.break (\c -> c == '\\' || c == '"') text+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 :: [Token] -> [Token]-stripComments = go 0+stripComments :: UnstrippedTokens -> UnstrippedTokens+stripComments = mapTokens (go 0) where go :: Int -> [Token] -> [Token] go _ [] = []@@ -205,127 +262,170 @@ | nest > 0 = go nest rest | otherwise = pos : go nest rest ---- | Break the input up into blocks based on indentation and strip out all--- the newlines. This way the blockTags doesn't need to worry about newlines.-breakBlocks :: [Token] -> [[Token]]-breakBlocks =- filter (not . null) . map (filter (not . isNewline)) . go . filterBlank+-- | 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 : breakBlocks post- -- Start the indent off at 1, this way the next line in the 0th column- -- will start a new block.- where (pre, post) = breakBlock True 1 tokens+ 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 newline, then take lines until there the indent decreases.-breakBlock :: Bool -> Int -> [Token] -> ([Token], [Token])-breakBlock _ _ [] = ([], [])-breakBlock firstLine indent (t@(Pos _ (Newline lineIndent)) : ts)- -- An indent less than the established block indent means I'm done.- | lineIndent < indent = ([t], ts)- | otherwise =- let (pre, post) = breakBlock False blockIndent ts in (t:pre, post)- where blockIndent = if firstLine then lineIndent else indent-breakBlock firstLine indent (t : ts) =- let (pre, post) = breakBlock firstLine indent ts in (t:pre, post)+-- | 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.------ Search for:--- - module <word>--- - newtype <word>--- - type <word>--- - data <word> * = <word> :: or | <word>--- - class * => <word> * where - strip indent, look for <word> ::--- - <word> :: emit as a definition--- - whitespace: skip to next line-blockTags :: [Token] -> [Tag]-blockTags tokens = case tokens of+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) : rest ->- mktag pos name Type : dataTags pos rest+ 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") : rest -> classTags pos rest- Pos pos (Token name) : Pos _ (Token "::") : _ -> [mktag pos name Function]- _ -> []+ Pos pos (Token "class") : _ -> classTags pos (mapTokens (drop 1) tokens)+ -- x, y, z :: *+ stripped -> fst $ functionTags False stripped -mktag :: SrcPos -> Text -> Type -> Pos TagVal-mktag pos name typ = Pos pos (Tag name typ)+-- | 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) -warning :: SrcPos -> String -> Pos TagVal-warning pos warn = Pos pos (Warning warn)+-- | 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) -unexpected :: SrcPos -> [Token] -> [Token] -> String -> [Tag]-unexpected prevPos tokens tokensHere declaration =- [warning pos ("unexpected " ++ thing ++ " after " ++ declaration)]+functionName :: Bool -> Text -> Maybe Text+functionName constructors text+ | isFunction text = Just text+ | isOperator text && not (T.null stripped) = Just stripped+ | otherwise = Nothing where- thing = if null tokensHere then "end of block"- else show (valOf (head tokensHere))- pos- | not (null tokensHere) = posOf (head tokensHere)- | not (null tokens) = posOf (last tokens)- | otherwise = prevPos+ 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 tokens rest "newtype * ="+ rest -> unexpected prevPos (UnstrippedTokens tokens) rest "newtype * =" -- | [] (empty data declaration) -- * = X { X :: *, X :: * } -- * where X :: * X :: * -- * = X | X-dataTags :: SrcPos -> [Token] -> [Tag]-dataTags _ [] = [] -- empty data declaration-dataTags prevPos tokens- -- if is gadt then...- | otherwise = case dropUntil "=" tokens of+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 tokens rest "data * ="+ rest -> unexpected prevPos unstripped rest "data * =" where- collectRest tokens = case tokens of- Pos pos (Token name) : Pos _ (Token "::") : rest ->- mktag pos name Function : collectRest rest- Pos _ (Token "|") : Pos pos (Token name) : rest ->- mktag pos name Constructor : collectRest rest- _ : rest -> collectRest rest- [] -> []+ 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 -> [Token] -> [Tag]-classTags prevPos unstripped = case tokens of- Pos pos (Token name) : rest ->- mktag pos name Class : collectRest rest- rest -> unexpected prevPos tokens rest "class * =>"+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- tokens = if any ((== Token "=>") . valOf) unstripped- then dropUntil "=>" unstripped else unstripped- collectRest tokens = case tokens of- Pos pos (Token name) : Pos _ (Token "::") : rest ->- mktag pos name Function : collectRest rest- _ : rest -> collectRest rest- [] -> []+ 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) @@ -339,6 +439,9 @@ -- * misc +tracem :: (Show a) => String -> a -> a+tracem msg x = Trace.trace (msg ++ ": " ++ show x) x+ (<>) :: (Monoid.Monoid a) => a -> a -> a (<>) = Monoid.mappend @@ -348,6 +451,10 @@ (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 _ [] = []-dropDups key (x:xs) = x : map snd (filter (not . equal) (zip (x:xs) xs))- where equal (x, y) = key x == key y
src/Main_test.hs view
@@ -1,87 +1,165 @@ {-# LANGUAGE OverloadedStrings #-} module Main_test where+import qualified Control.Exception as Exception import Control.Monad-import qualified Data.Maybe as Maybe+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 (Token, TokenVal(..), TagVal(..), Type(..))+import Main (TokenVal(..), TagVal(..), Type(..), Tag, Pos(..)) --- This is kind of annoying without line numbers on equal and automatic--- test_* collection...+-- This is kind of annoying without automatic test_* collection... main = do test_tokenize- test_breakString+ test_skipString test_stripComments test_process test_tokenize = do- let f = extractTokens . tokenize- equal (f "a::b->c") ["nl 0", "a", "::", "b", "->", "c"]- equal (f "x{-\n bc#-}\n")- ["nl 0", "x", "{-", "nl 2", "bc", "#", "-}"]- equal (f "X.Y") ["nl 0", "X.Y"]+ -- 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_breakString = do- let f = Main.breakString- equal (f "hi \" there") ("hi \"", " there")- equal (f "hi \\a \" there") ("hi \\a \"", " there")- equal (f "hi \\\" there\"") ("hi \\\" there\"", "")- equal (f "hi") ("hi", "")+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 (f "hi \\") ("hi \\", "")+ equal assert (f "hi \\") "" test_stripComments = do let f = extractTokens . Main.stripComments . tokenize- equal (f "hello -- there") ["nl 0", "hello"]- equal (f "hello {- there -} fred") ["nl 0", "hello", "fred"]- equal (f "{-# LANG #-} hello {- there {- nested -} comment -} fred")+ 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.breakBlocks . tokenize- equal (f "1\n2\n") [["1"], ["2"]]- equal (f "1\n 1\n2\n") [["1", "1"], ["2"]]- equal (f "1\n 1\n 1\n2\n") [["1", "1", "1"], ["2"]]+ 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 (f "1\n 1\n\n 1\n2\n") [["1", "1", "1"], ["2"]]- equal (f "1\n\n\n 1\n2\n") [["1", "1"], ["2"]]+ 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"]] -test_process = do- let f = map Main.valOf . Main.process "fn"- equal (f "module Bar.Foo where\n") [Tag "Foo" Module]- equal (f "newtype Foo a b =\n\tBar x y z\n")- [Tag "Foo" Type, Tag "Bar" Constructor]- equal (f "data Foo a = Bar { field :: Field }")- [Tag "Foo" Type, Tag "Bar" Constructor, Tag "field" Function]- equal (f "data Foo = Bar | Baz")- [Tag "Foo" Type, Tag "Bar" Constructor, Tag "Baz" Constructor]- equal (f "class (X x) => C a b c where\n\tm :: a -> b\n\tn :: c -> d\n")- [Tag "C" Class, Tag "m" Function, Tag "n" Function]- equal (f "class A a where f :: X\n")- [Tag "A" Class, Tag "f" Function]- equal (f "data X\n") [Tag "X" Type]+ equal assert (f "1\n 11\n 11\n") [["1", "11", "11"]]+ equal assert (f " 11\n 11\n") [["11"], ["11"]] - -- The extra X is suppressed.- equal (f "data X = X Int\n") [Tag "X" Type]+test_process = sequence_+ [test_misc, test_data, test_gadt, test_families, test_functions, test_class] - equal (f "f :: A -> B\ng :: C -> D\ndata D = C {\n\tf :: A\n\t}\n")+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 "Foo" Type, Tag "Bar" Constructor]+ equal assert (f "f :: A -> B\ng :: C -> D\ndata D = C {\n\tf :: A\n\t}\n") [Tag "f" Function, Tag "g" Function, Tag "D" Type, Tag "C" Constructor, Tag "f" Function] +test_unicode = do+ let f = process+ equal assert (f "數字 :: Int") ["數字"]+ equal assert (f "(·), x :: Int") ["·", "x"] -tokenize :: Text.Text -> [Token]-tokenize = concat . map Main.tokenize . Main.stripCpp . Main.annotate "fn"+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") ["Foo", "Bar", "Baz"]+ equal assert (f "data Foo =\n\tBar\n\t| Baz") ["Foo", "Bar", "Baz"]+ -- Records.+ equal assert (f "data Foo a = Bar { field :: Field }")+ ["Foo", "Bar", "field"]+ equal assert (f "data R = R { a::X, b::Y }") ["R", "a", "b"]+ equal assert (f "data R = R {\n\ta::X\n\t, b::Y\n\t}") ["R", "a", "b"]+ equal assert (f "data R = R {\n\ta,b::X\n\t}") ["R", "a", "b"] + equal assert (f "data R = R {\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") ["X", "A"]+ equal assert (f "data X where\n\tA :: X\n") ["X", "A"]+ equal assert (f "data X where\n\tA :: X\n\tB :: X\n") ["X", "A", "B"]+ equal assert (f "data X where\n\tA, B :: X\n") ["X", "A", "B"]++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 :: [Token] -> [Text.Text]-extractTokens = Maybe.mapMaybe $ \token -> case Main.valOf token of- Token name -> Just name- Newline n -> Just (Text.pack ("nl " ++ show 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) => a -> a -> IO ()-equal x y = unless (x == y) $- putStrLn $ "__: " ++ show x ++ " /= " ++ show y+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)+
+ src/T.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE GADTs #-}+module T where+++數字 :: Int+數字 = 2++(·) = (.)++data X where+ A, B :: X