diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ Usage ----- -Cgrep 6.5.7 Usage: cgrep [OPTION] [PATTERN] files... +Cgrep 6.5.8 Usage: cgrep [OPTION] [PATTERN] files... cgrep [OPTIONS] [ITEM] diff --git a/cgrep.cabal b/cgrep.cabal --- a/cgrep.cabal +++ b/cgrep.cabal @@ -1,6 +1,6 @@ Name: cgrep Description: Cgrep: a context-aware grep for source codes -Version: 6.5.7 +Version: 6.5.8 Synopsis: Command line tool Homepage: http://awgn.github.io/cgrep/ License: GPL-2 @@ -25,7 +25,7 @@ BangPatterns, FlexibleInstances, FlexibleContexts - Other-Modules: Debug Options CmdOptions Util Config CGrep.Lang CGrep.Filter CGrep.Token CGrep.Types CGrep.CGrep CGrep.Output CGrep.Distance CGrep.Common CGrep.Context CGrep.Semantic.WildCard CGrep.Semantic.Generic.Token CGrep.Semantic.Token CGrep.Semantic.Cpp.Token CGrep.Strategy.Generic.Semantic CGrep.Strategy.Levenshtein CGrep.Strategy.BoyerMoore CGrep.Strategy.Cpp.Tokenizer CGrep.Strategy.Cpp.Semantic CGrep.Strategy.Regex + Other-Modules: Debug Options CmdOptions Util Config CGrep.Lang CGrep.Filter CGrep.Token CGrep.Types CGrep.CGrep CGrep.Output CGrep.Distance CGrep.Common CGrep.Context CGrep.Parser.WildCard CGrep.Parser.Generic.Token CGrep.Parser.Token CGrep.Parser.Cpp.Token CGrep.Strategy.Generic.Semantic CGrep.Strategy.Levenshtein CGrep.Strategy.BoyerMoore CGrep.Strategy.Cpp.Tokenizer CGrep.Strategy.Cpp.Semantic CGrep.Strategy.Regex Build-Depends: base < 5.0, cmdargs >=0.10, bytestring >=0.10, diff --git a/src/CGrep/CGrep.hs b/src/CGrep/CGrep.hs --- a/src/CGrep/CGrep.hs +++ b/src/CGrep/CGrep.hs @@ -16,7 +16,7 @@ -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -module CGrep.CGrep (sanitizeOptions, cgrepDispatch) where +module CGrep.CGrep (sanitizeOptions, runCgrep) where import qualified CGrep.Strategy.BoyerMoore as BoyerMoore import qualified CGrep.Strategy.Levenshtein as Levenshtein @@ -56,19 +56,20 @@ hasTokenizerOpt :: Options -> Bool hasTokenizerOpt Options - { identifier = i - , keyword = k - , directive = d - , header = h - , number = n - , string = s - , char = c - , oper = o - } = i || k || d || h || n || s || c || o + { identifier = i + , keyword = k + , directive = d + , header = h + , number = n + , string = s + , char = c + , oper = o + } = i || k || d || h || n || s || c || o -cgrepDispatch :: FilePath -> [Text8] -> ReaderT Options IO [Output] -cgrepDispatch filename patterns = do + +runCgrep :: FilePath -> [Text8] -> ReaderT Options IO [Output] +runCgrep filename patterns = do opt <- ask case () of _ | not (regex opt) && not (hasTokenizerOpt opt) && not (semantic opt) && edit_dist opt -> Levenshtein.search filename patterns diff --git a/src/CGrep/Common.hs b/src/CGrep/Common.hs --- a/src/CGrep/Common.hs +++ b/src/CGrep/Common.hs @@ -20,13 +20,14 @@ getTargetName, getTargetContents, quickSearch, - runSearch, + runQuickSearch, expandMultiline, ignoreCase, trim, trim8) where import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Search as SC + import Data.Char import Control.Monad.Trans.Reader @@ -62,11 +63,11 @@ where has_pattern pat = notNull $ pat `SC.nonOverlappingIndices` text -runSearch :: FilePath +runQuickSearch :: FilePath -> Maybe Bool -- quicksearch -> ReaderT Options IO [Output] -> ReaderT Options IO [Output] -runSearch filename quick doSearch = +runQuickSearch filename quick doSearch = if maybe False not quick then mkOutput filename C.empty C.empty [] else doSearch @@ -79,7 +80,7 @@ ignoreCase :: Options -> Text8 -> Text8 -ignoreCase Options { ignore_case = icase } - | icase = C.map toLowercase +ignoreCase opt + | ignore_case opt = C.map toLowercase | otherwise = id diff --git a/src/CGrep/Parser/Cpp/Token.hs b/src/CGrep/Parser/Cpp/Token.hs new file mode 100644 --- /dev/null +++ b/src/CGrep/Parser/Cpp/Token.hs @@ -0,0 +1,381 @@ +-- +-- Copyright (c) 2012-2013 Bonelli Nicola +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +-- + +{-# LANGUAGE ViewPatterns #-} + +module CGrep.Parser.Cpp.Token(Token(..), TokenFilter(..), + Offset, tokenizer, tokenFilter, tokenCompare, + isIdentifier, isKeyword, isDirective, isLiteralNumber, + isHeaderName, isString, isChar, isOperOrPunct + ) where + +import Data.Char +import Data.Maybe +import Control.Monad +import Data.Array.Unboxed + +import qualified Data.HashSet as HS +import qualified Data.HashMap.Strict as HM +import qualified Data.ByteString.Char8 as C + +import CGrep.Parser.Token + +data TokenizerState = TokenizerState Source {-# UNPACK #-} !Offset !CppState +type Source = C.ByteString +type Offset = Int + + +data Token = + TokenIdentifier { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | + TokenDirective { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | + TokenKeyword { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | + TokenNumber { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | + TokenHeaderName { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | + TokenString { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | + TokenChar { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | + TokenOperOrPunct { toString :: !String, toOffset :: {-# UNPACK #-} !Int } + deriving (Show, Eq, Ord) + + +data TokenFilter = TokenFilter + { filtIdentifier :: !Bool + , filtDirective :: !Bool + , filtKeyword :: !Bool + , filtHeader :: !Bool + , filtString :: !Bool + , filtNumber :: !Bool + , filtChar :: !Bool + , filtOper :: !Bool + } deriving (Eq) + + +instance SemanticToken Token where + tkIsIdentifier = isIdentifier + tkIsString = isString + tkIsChar = isChar + tkIsNumber = isLiteralNumber + tkIsKeyword = isKeyword + tkEquivalent = tokenCompare + tkToString = toString + tkToOffset = toOffset + tkToIdentif = TokenIdentifier + + +-- Tokenize the source code in a list of Token +-- Precondition: the C++ source code must be well-formed +-- + +tokenizer :: Source -> [Token] +tokenizer xs = runGetToken (TokenizerState ys n Null) + where (ys, n) = dropWhite xs + + +tokenFilter :: TokenFilter -> Token -> Bool +tokenFilter filt (TokenIdentifier{}) = filtIdentifier filt +tokenFilter filt (TokenDirective{}) = filtDirective filt +tokenFilter filt (TokenKeyword{}) = filtKeyword filt +tokenFilter filt (TokenHeaderName{}) = filtHeader filt +tokenFilter filt (TokenNumber{}) = filtNumber filt +tokenFilter filt (TokenString{}) = filtString filt +tokenFilter filt (TokenChar{}) = filtChar filt +tokenFilter filt (TokenOperOrPunct{}) = filtOper filt + + +tokenCompare :: Token -> Token -> Bool +tokenCompare (TokenIdentifier { toString = l }) (TokenIdentifier { toString = r }) = l == r +tokenCompare (TokenDirective { toString = l }) (TokenDirective { toString = r }) = l == r +tokenCompare (TokenKeyword { toString = l }) (TokenKeyword { toString = r }) = l == r +tokenCompare (TokenNumber { toString = l }) (TokenNumber { toString = r }) = l == r +tokenCompare (TokenHeaderName { toString = l }) (TokenHeaderName { toString = r }) = l == r +tokenCompare (TokenString { toString = l }) (TokenString { toString = r }) = l == r +tokenCompare (TokenChar { toString = l }) (TokenChar { toString = r }) = l == r +tokenCompare (TokenOperOrPunct{ toString = l }) (TokenOperOrPunct{ toString = r }) = l == r +tokenCompare _ _ = False + + +isIdentifier :: Token -> Bool +isIdentifier (TokenIdentifier {}) = True +isIdentifier _ = False + + +isKeyword :: Token -> Bool +isKeyword (TokenKeyword {}) = True +isKeyword _ = False + + +isDirective :: Token -> Bool +isDirective (TokenDirective {}) = True +isDirective _ = False + + +isLiteralNumber :: Token -> Bool +isLiteralNumber (TokenNumber {}) = True +isLiteralNumber _ = False + + +isHeaderName :: Token -> Bool +isHeaderName (TokenHeaderName {}) = True +isHeaderName _ = False + + +isString :: Token -> Bool +isString (TokenString {}) = True +isString _ = False + + +isChar :: Token -> Bool +isChar (TokenChar {}) = True +isChar _ = False + + +isOperOrPunct :: Token -> Bool +isOperOrPunct (TokenOperOrPunct {}) = True +isOperOrPunct _ = False + + +isIdentifierChar' :: Char -> Bool +isIdentifierChar' = ((listArray ('\0', '\255') (map (\c -> isAlphaNum c || c == '_' || c == '$') ['\0'..'\255']) :: UArray Char Bool) !) -- GNU allows $ in identifier + + +isChar' :: Char -> Bool +isChar'= ((listArray ('\0', '\255') (map (\c -> isSpace c || c == '\\') ['\0'..'\255']) :: UArray Char Bool) !) + +-- Drop leading whitespace and count them +-- + +{-# INLINE dropWhite #-} + +dropWhite :: Source -> (Source, Offset) +dropWhite xs = (xs', doff) + where xs' = C.dropWhile isChar' xs + doff = fromIntegral $ C.length xs - C.length xs' + + +data CppState = Null | Hash | Include | Define | Undef | If | Ifdef | Ifndef | Elif | Else | Endif | + Line | Error | Pragma + deriving (Show, Eq) + + +directiveKeys :: HM.HashMap String CppState +directiveKeys = HM.fromList [ ("#", Hash), + ("include", Include), + ("include_next", Include), + ("define", Define), + ("undef", Undef), + ("if", If), + ("ifdef", Ifdef), + ("ifndef", Ifndef), + ("elif", Elif), + ("else", Else), + ("endif", Null), + ("line", Line), + ("error", Error), + ("pragma", Pragma) ] + + +nextCppState :: String -> CppState -> CppState +nextCppState str pps + | Hash <- pps = fromMaybe Null (HM.lookup str directiveKeys) + | otherwise = if str == "#" then Hash else Null + + +runGetToken :: TokenizerState -> [Token] + +runGetToken (TokenizerState (C.uncons -> Nothing) _ _) = [] +runGetToken tstate = token : runGetToken ns + where (token, ns) = getToken tstate + + +getToken :: TokenizerState -> (Token, TokenizerState) + +getToken (TokenizerState (C.uncons -> Nothing) _ _) = error "getToken: internal error" +getToken (TokenizerState xs off state) = + let token = fromJust $ + getTokenDirective xs state `mplus` + getTokenHeaderName xs state `mplus` + getTokenNumber xs state `mplus` + getTokenString xs state `mplus` + getTokenChar xs state `mplus` + getTokenIdOrKeyword xs state `mplus` + getTokenOpOrPunct xs state + tstring = toString token + len = fromIntegral $ length tstring + (xs', w) = dropWhite $ C.drop (fromIntegral len) xs + in + (token { toOffset = off }, TokenizerState xs' (off + len + w) (nextCppState tstring state)) + + +getTokenIdOrKeyword, getTokenNumber, + getTokenHeaderName, getTokenString, + getTokenChar, getTokenOpOrPunct, + getTokenDirective :: Source -> CppState -> Maybe Token + + +getTokenDirective xs state + | state == Hash = Just (TokenDirective name 0) + | otherwise = Nothing + where name = C.unpack $ C.takeWhile isIdentifierChar' xs + + +getTokenHeaderName (C.uncons -> Nothing) _ = error "getTokenHeaderName: internal error" +getTokenHeaderName xs@(C.uncons -> Just (x,_)) state + | state /= Include = Nothing + | x == '<' = Just $ TokenHeaderName (getLiteral '<' '>' False xs) 0 + | x == '"' = Just $ TokenHeaderName (getLiteral '"' '"' False xs) 0 + | otherwise = Just $ TokenHeaderName (C.unpack $ C.takeWhile isIdentifierChar' xs) 0 + +getTokenHeaderName _ _ = undefined + + +getTokenNumber ys@(C.uncons -> Just (x,_)) _ + | x == '.' || isDigit x = let ts = getNumber ys NumberNothing in + case ts of + "" -> Nothing + "." -> Nothing + _ -> Just $ TokenNumber ts 0 + | otherwise = Nothing +getTokenNumber (C.uncons -> Nothing) _ = Nothing +getTokenNumber _ _ = undefined + + +validHexSet, validOctSet, validDecSet :: HS.HashSet Char + +validHexSet = HS.fromList "0123456789abcdefABCDEFxX" +validOctSet = HS.fromList "01234567" +validDecSet = HS.fromList "0123456789" + +data NumberState = NumberNothing | NumberOHF | NumberDec | NumberOct | NumberHex | NumberMayBeFloat | NumberFloat | NumberExp + deriving (Show,Eq,Enum) + +getNumber :: C.ByteString -> NumberState -> String +-- getNumber xs s | trace ("state = " ++ show s) False = undefined + +getNumber (C.uncons -> Nothing) _ = "" +getNumber (C.uncons -> Just (x,xs)) state + | state == NumberNothing = case () of _ + | x == '0' -> x : getNumber xs NumberOHF + | x == '.' -> x : getNumber xs NumberMayBeFloat + | isDigit x -> x : getNumber xs NumberDec + | otherwise -> "" + | state == NumberOHF = case () of _ + | x `HS.member` validHexSet -> x : getNumber xs NumberHex + | x == '.' -> x : getNumber xs NumberMayBeFloat + | isDigit x -> x : getNumber xs NumberOct + | otherwise -> "" + + | state == NumberDec = case () of _ + | x `HS.member` validDecSet -> x : getNumber xs NumberDec + | x == '.' -> x : getNumber xs NumberMayBeFloat + | x == 'e' || x == 'E' -> x : getNumber xs NumberExp + | otherwise -> "" + + | state == NumberOct = case () of _ + | x `HS.member` validOctSet -> x : getNumber xs NumberOct + | otherwise -> "" + + | state == NumberHex = case () of _ + | x `HS.member` validHexSet -> x : getNumber xs NumberHex + | otherwise -> "" + + | state == NumberMayBeFloat = case () of _ + | x `HS.member` validDecSet -> x : getNumber xs NumberFloat + | otherwise -> "" + + | state == NumberFloat = case () of _ + | x `HS.member` validDecSet -> x : getNumber xs NumberFloat + | x == 'e' || x == 'E' -> x : getNumber xs NumberExp + | otherwise -> "" + + | state == NumberExp = case () of _ + | x `HS.member` validDecSet -> x : getNumber xs NumberExp + | x == '+' || x == '-' -> x : getNumber xs NumberExp + | otherwise -> "" + +getNumber _ _ = undefined + + +getTokenString xs@(C.uncons -> Just (x,_)) _ + | x == '"' = Just $ TokenString (getLiteral '"' '"' False xs) 0 + | otherwise = Nothing +getTokenString (C.uncons -> Nothing) _ = Nothing +getTokenString _ _ = Nothing + + +getTokenChar xs@(C.uncons -> Just (x,_)) _ + | x == '\'' = Just $ TokenChar (getLiteral '\'' '\'' False xs) 0 + | otherwise = Nothing +getTokenChar (C.uncons -> Nothing) _ = Nothing +getTokenChar _ _ = Nothing + + +getTokenIdOrKeyword xs@(C.uncons -> Just (x,_)) _ + | not $ isIdentifierChar' x = Nothing + | name `HS.member` keywords = Just $ TokenKeyword name 0 + | otherwise = Just $ TokenIdentifier name 0 + where name = C.unpack $ C.takeWhile isIdentifierChar' xs +getTokenIdOrKeyword (C.uncons -> Nothing) _ = Nothing +getTokenIdOrKeyword _ _ = Nothing + + +getTokenOpOrPunct source _ = go source (min 4 (C.length source)) + where go _ 0 + | C.length source > 0 = error $ "operator or punct: error " ++ show source + | otherwise = Nothing + go src len + | sub `HS.member` operOrPunct = Just $ TokenOperOrPunct sub 0 + | otherwise = go src (len-1) + where sub = C.unpack (C.take len src) + + +getLiteral :: Char -> Char -> Bool -> C.ByteString -> String +getLiteral _ _ _ (C.uncons -> Nothing) = [] +getLiteral b e False ys@(C.uncons -> Just (x,xs)) + | x == b = b : getLiteral b e True xs + | otherwise = error $ "literal: error " ++ C.unpack ys +getLiteral b e True (C.uncons -> Just (x,xs)) + | x == e = [e] + | x == '\\' = '\\' : x' : getLiteral b e True xs' + | otherwise = x : getLiteral b e True xs + where + (C.uncons -> Just(x',xs')) = xs +getLiteral _ _ _ _ = [] + + +operOrPunct :: HS.HashSet String +operOrPunct = HS.fromList [ "{","}","[","]","#","(",")",";",":","?",".","+","-","*", + "/","%","^","&","|","~","!","=","<",">","," , + "##", "<:", ":>", "<%", "%>", "%:", "::", ".*", "+=", "-=", + "*=", "/=", "%=", "^=", "&=", "|=", "<<", ">>", ">=", "<=", + "&&", "||", "==", "!=", "++", "--", "->", "//", "/*", "*/", + "...", "<<=", ">>=", "->*", + "%:%:" ] + +keywords :: HS.HashSet String +keywords = HS.fromList ["alignas", "continue", "friend", "alignof", "decltype", "goto", "asm", + "default", "if", "auto", "delete", "inline", "bool", "do", "int", "break", + "double", "long", "case", "dynamic_cast", "mutable", "catch", "else", + "namespace", "char", "enum", "new", "char16_t", "explicit", "noexcept", + "char32_t", "export", "nullptr", "class", "extern", "operator", "const", + "false", "private", "constexpr", "float", "protected", "const_cast", "for", + "public", "register", "true", "reinterpret_cast", "try", "return", "typedef", + "short", "typeid", "signed", "typename", "sizeof", "union", "static", "unsigned", + "static_assert", "using", "static_cast", "virtual", "struct", "void", "switch", + "volatile", "template", "wchar_t", "this", "while", "thread_local", "throw", + "and", "and_eq", "bitand", "bitor", "compl", "not", "not_eq", "or", "or_eq", + "xor", "xor_eq"] + diff --git a/src/CGrep/Parser/Generic/Token.hs b/src/CGrep/Parser/Generic/Token.hs new file mode 100644 --- /dev/null +++ b/src/CGrep/Parser/Generic/Token.hs @@ -0,0 +1,213 @@ +-- +-- Copyright (c) 2013 Bonelli Nicola +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +-- + +{-# LANGUAGE FlexibleInstances #-} + + +module CGrep.Parser.Generic.Token (tokenizer, Token(..)) where + +import qualified Data.ByteString.Char8 as C +import qualified Data.DList as DL + +import Data.Char +import Data.Array.Unboxed + +import CGrep.Parser.Token +import CGrep.Types + +type DString = DL.DList Char + + +data TokenState = + StateSpace | + StateAlpha | + StateDigit | + StateBracket | + StateLit1 | + StateLit2 | + StateOther + deriving (Eq, Enum, Show) + + +data Token = + TokenAlpha { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } | + TokenDigit { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } | + TokenBracket { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } | + TokenLiteral { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } | + TokenOther { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } + deriving (Show, Eq, Ord) + + +instance SemanticToken Token where + tkIsIdentifier = _isTokenAlpha + tkIsString = _isTokenLiteral + tkIsChar = _isTokenLiteral + tkIsNumber = _isTokenDigit + tkIsKeyword = const False + tkEquivalent = tokenCompare + tkToString = toString + tkToOffset = toOffset + tkToIdentif = TokenAlpha + + +_isTokenAlpha, _isTokenDigit, _isTokenBracket, _isTokenOther, _isTokenLiteral :: Token -> Bool + +_isTokenAlpha (TokenAlpha _ _) = True +_isTokenAlpha _ = False + +_isTokenDigit (TokenDigit _ _) = True +_isTokenDigit _ = False + +_isTokenBracket (TokenBracket _ _) = True +_isTokenBracket _ = False + +_isTokenLiteral (TokenLiteral _ _) = True +_isTokenLiteral _ = False + +_isTokenOther (TokenOther _ _) = True +_isTokenOther _ = False + + +tokenCompare :: Token -> Token -> Bool +tokenCompare (TokenAlpha { toString = l }) (TokenAlpha { toString = r }) = l == r +tokenCompare (TokenDigit { toString = l }) (TokenDigit { toString = r }) = l == r +tokenCompare (TokenLiteral { toString = l }) (TokenLiteral { toString = r }) = l == r +tokenCompare (TokenBracket { toString = l }) (TokenBracket { toString = r }) = l == r +tokenCompare (TokenOther { toString = l }) (TokenOther { toString = r }) = l == r +tokenCompare _ _ = False + + +data TokenAccum = TokenAccum !TokenState {-# UNPACK #-} !Offset {-# UNPACK #-} !Int DString (DL.DList Token) + + +isCharNumberLT :: UArray Char Bool +isCharNumberLT = + listArray ('\0', '\255') + (map (\c -> isHexDigit c || c `elem` ".xX") ['\0'..'\255']) + + +isSpaceLT :: UArray Char Bool +isSpaceLT = + listArray ('\0', '\255') + (map isSpace ['\0'..'\255']) + +isAlphaLT :: UArray Char Bool +isAlphaLT = + listArray ('\0', '\255') + (map (\c -> isAlpha c || c == '_') ['\0'..'\255']) + +isAlphaNumLT :: UArray Char Bool +isAlphaNumLT = + listArray ('\0', '\255') + (map (\c -> isAlphaNum c || c == '_' || c == '\'') ['\0'..'\255']) + +isDigitLT :: UArray Char Bool +isDigitLT = + listArray ('\0', '\255') + (map isDigit ['\0'..'\255']) + +isBracketLT :: UArray Char Bool +isBracketLT = + listArray ('\0', '\255') + (map (`elem` "{[()]}") ['\0'..'\255']) + + +{-# INLINE mkToken #-} + + +mkToken :: (String -> Offset -> Token) -> Offset -> DString -> Token +mkToken ctor off ds = ctor str (off - length str) + where str = DL.toList ds + + +mkTokenCtor :: TokenState -> String -> Offset -> Token +mkTokenCtor StateSpace = TokenOther +mkTokenCtor StateAlpha = TokenAlpha +mkTokenCtor StateDigit = TokenDigit +mkTokenCtor StateBracket = TokenBracket +mkTokenCtor StateLit1 = TokenLiteral +mkTokenCtor StateLit2 = TokenLiteral +mkTokenCtor StateOther = TokenOther + + +tokenizer :: Text8 -> [Token] +tokenizer xs = (\(TokenAccum ss off _ acc out) -> + DL.toList (if null (DL.toList acc) then out + else out `DL.snoc` mkToken (mkTokenCtor ss) off acc)) $ C.foldl' tokens' (TokenAccum StateSpace 0 0 DL.empty DL.empty) xs + where tokens' :: TokenAccum -> Char -> TokenAccum + tokens' (TokenAccum StateSpace off _ _ out) x = + case () of + _ | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty out + | x == '\'' -> TokenAccum StateLit1 (off+1) 0 (DL.singleton x) out + | x == '"' -> TokenAccum StateLit2 (off+1) 0 (DL.singleton x) out + | isAlphaLT ! x -> TokenAccum StateAlpha (off+1) 0 (DL.singleton x) out + | isDigitLT ! x -> TokenAccum StateDigit (off+1) 0 (DL.singleton x) out + | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) out + | otherwise -> TokenAccum StateOther (off+1) 0 (DL.singleton x) out + + tokens' (TokenAccum StateAlpha off _ acc out) x = + case () of + _ | isAlphaNumLT ! x -> TokenAccum StateAlpha (off+1) 0 (acc `DL.snoc` x) out + | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenAlpha off acc) + | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenAlpha off acc) + | otherwise -> TokenAccum StateOther (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenAlpha off acc) + + tokens' (TokenAccum StateDigit off _ acc out) x = + case () of + _ | isCharNumberLT ! x -> TokenAccum StateDigit (off+1) 0 (acc `DL.snoc` x) out + | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenDigit off acc) + | isAlphaLT ! x -> TokenAccum StateAlpha (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenDigit off acc) + | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenDigit off acc) + | otherwise -> TokenAccum StateOther (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenDigit off acc) + + tokens' (TokenAccum StateLit1 off skip acc out) x = + case () of + _ | skip > 0 -> TokenAccum StateLit1 (off+1) (skip-1) (acc `DL.snoc` x) out + | x == '\\' -> TokenAccum StateLit1 (off+1) 1 (acc `DL.snoc` x) out + | x == '\'' -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenLiteral (off+1) (acc `DL.snoc` '\'')) + | otherwise -> TokenAccum StateLit1 (off+1) 0 (acc `DL.snoc` x) out + + tokens' (TokenAccum StateLit2 off skip acc out) x = + case () of + _ | skip > 0 -> TokenAccum StateLit2 (off+1) (skip-1) (acc `DL.snoc` x) out + | x == '\\' -> TokenAccum StateLit2 (off+1) 1 (acc `DL.snoc` x) out + | x == '"' -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenLiteral (off+1) (acc `DL.snoc` '"')) + | otherwise -> TokenAccum StateLit2 (off+1) 0 (acc `DL.snoc` x) out + + tokens' (TokenAccum StateBracket off _ acc out) x = + case () of + _ | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenBracket off acc) + | isAlphaLT ! x -> TokenAccum StateAlpha (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) + | isDigitLT ! x -> TokenAccum StateDigit (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) + | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) + | x == '\'' -> TokenAccum StateLit1 (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) + | x == '"' -> TokenAccum StateLit2 (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) + | otherwise -> TokenAccum StateOther (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) + + tokens' (TokenAccum StateOther off _ acc out) x = + case () of + _ | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenOther off acc) + | isAlphaLT ! x -> TokenAccum StateAlpha (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenOther off acc) + | isDigitLT ! x -> if DL.toList acc == "." + then TokenAccum StateDigit (off+1) 0 (acc `DL.snoc` x) out + else TokenAccum StateDigit (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenOther off acc) + | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenOther off acc) + | x == '\'' -> TokenAccum StateLit1 (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) + | x == '"' -> TokenAccum StateLit2 (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) + | otherwise -> TokenAccum StateOther (off+1) 0 (acc `DL.snoc` x) out + diff --git a/src/CGrep/Parser/Token.hs b/src/CGrep/Parser/Token.hs new file mode 100644 --- /dev/null +++ b/src/CGrep/Parser/Token.hs @@ -0,0 +1,32 @@ +-- +-- Copyright (c) 2013 Bonelli Nicola +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +-- + +module CGrep.Parser.Token (SemanticToken(..)) where + + +class (Show t, Ord t) => SemanticToken t where + tkIsIdentifier :: t -> Bool + tkIsString :: t -> Bool + tkIsChar :: t -> Bool + tkIsNumber :: t -> Bool + tkIsKeyword :: t -> Bool + tkEquivalent :: t -> t -> Bool + tkToString :: t -> String + tkToOffset :: t -> Int + tkToIdentif :: String -> Int -> t + diff --git a/src/CGrep/Parser/WildCard.hs b/src/CGrep/Parser/WildCard.hs new file mode 100644 --- /dev/null +++ b/src/CGrep/Parser/WildCard.hs @@ -0,0 +1,220 @@ +-- +-- Copyright (c) 2013 Bonelli Nicola +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +-- + +module CGrep.Parser.WildCard (WildCard(..), MultiCard, + mkWildCardFromToken, + combineMultiCard, + filterTokensWithMultiCards, + wildCardMatch, + multiCardMatch) where + +import qualified Data.Map as M + +import CGrep.Common +import CGrep.Distance +import CGrep.Parser.Token + +import Data.Char +import Data.List +import Options +import Util + + +data WildCard a = + TokenCard a | + AnyCard | + KeyWordCard | + NumberCard | + OctCard | + HexCard | + StringCard | + LiteralCard | + CharCard | + IdentifCard String + deriving (Show, Eq, Ord) + + + +type MultiCard a = [WildCard a] + + +wildCardMap :: M.Map String (WildCard a) +wildCardMap = M.fromList + [ + ("ANY", AnyCard ), + ("KEY", KeyWordCard ), + ("OCT", OctCard ), + ("HEX", HexCard ), + ("NUM", NumberCard ), + ("CHR", CharCard ), + ("STR", StringCard ), + ("LIT", StringCard ) + ] + + +mkWildCardFromToken :: (SemanticToken a) => a -> WildCard a +mkWildCardFromToken t + | tkIsIdentifier t = case () of + _ | Just wc <- M.lookup str wildCardMap -> wc + | isWildCardIdentif str -> IdentifCard str + | otherwise -> TokenCard $ tkToIdentif (rmWildCardEscape str) (tkToOffset t) + where str = tkToString t + + | otherwise = TokenCard t + + +combineMultiCard :: (SemanticToken a) => [MultiCard a] -> [MultiCard a] +combineMultiCard (m1:r@(m2:m3:ms)) + | [TokenCard b] <- m2, tkToString b == "OR" = combineMultiCard $ (m1++m3):ms + | otherwise = m1 : combineMultiCard r +combineMultiCard [m1,m2] = [m1,m2] +combineMultiCard [m1] = [m1] +combineMultiCard [] = [] + + +filterTokensWithMultiCards :: (SemanticToken a) => Options -> [MultiCard a] -> [a] -> [a] +filterTokensWithMultiCards opt ws = filterTokensWithMultiCards' opt (spanOptionalCards ws) + + +filterTokensWithMultiCards' :: (SemanticToken a) => Options -> [[MultiCard a]] -> [a] -> [a] +filterTokensWithMultiCards' _ [] _ = [] +filterTokensWithMultiCards' opt (g:gs) ts = + concatMap (take grpLen . (`drop` ts)) (findIndices (multiCardCompare opt g) grp) ++ + filterTokensWithMultiCards' opt gs ts + where grp = spanGroup grpLen ts + grpLen = length g + + +spanOptionalCards :: [MultiCard a] -> [[MultiCard a]] +spanOptionalCards wc = map (`filterCardIndicies` wc') idx + where wc' = zip [0..] wc + idx = subsequences $ + findIndices (\w -> case w of + [IdentifCard ('$':_)] -> True + _ -> False) wc + + +filterCardIndicies :: [Int] -> [(Int, MultiCard a)] -> [MultiCard a] +filterCardIndicies ns ps = map snd $ filter (\(n, _) -> n `notElem` ns) ps + + +multiCardCompare :: (SemanticToken a) => Options -> [MultiCard a] -> [a] -> Bool +multiCardCompare opt l r = + multiCardCompareAll ts && multiCardCheckOccurences ts + where ts = multiCardGroupCompare opt l r + + +isWildCardIdentif :: String -> Bool +isWildCardIdentif s = + case () of + _ | (x:y:_) <- s -> wprefix x && isNumber y + | [x] <- s -> wprefix x + | otherwise -> error "isWildCardIdentif" + where wprefix x = x == '$' || x == '_' + + +rmWildCardEscape :: String -> String +rmWildCardEscape ('$':xs) = xs +rmWildCardEscape ('_':xs) = xs +rmWildCardEscape xs = xs + + +{-# INLINE multiCardCompareAll #-} + +multiCardCompareAll :: [(Bool, (MultiCard a, [String]))] -> Bool +multiCardCompareAll = all fst + + +{-# INLINE multiCardCheckOccurences #-} + +-- Note: pattern $ and _ match any token, whereas $1 $2 (_1 _2 etc.) match tokens +-- that must compare equal in the respective occurrences +-- + +multiCardCheckOccurences :: (SemanticToken a) => [(Bool, (MultiCard a, [String]))] -> Bool +multiCardCheckOccurences ts = M.foldr (\xs r -> r && all (== head xs) xs) True m + where m = M.mapWithKey (\k xs -> + case k of + [IdentifCard "_0"] -> xs + [IdentifCard "_1"] -> xs + [IdentifCard "_2"] -> xs + [IdentifCard "_3"] -> xs + [IdentifCard "_4"] -> xs + [IdentifCard "_5"] -> xs + [IdentifCard "_6"] -> xs + [IdentifCard "_7"] -> xs + [IdentifCard "_8"] -> xs + [IdentifCard "_9"] -> xs + [IdentifCard "$0"] -> xs + [IdentifCard "$1"] -> xs + [IdentifCard "$2"] -> xs + [IdentifCard "$3"] -> xs + [IdentifCard "$4"] -> xs + [IdentifCard "$5"] -> xs + [IdentifCard "$6"] -> xs + [IdentifCard "$7"] -> xs + [IdentifCard "$8"] -> xs + [IdentifCard "$9"] -> xs + _ -> [] + ) $ M.fromListWith (++) (map snd ts) + + +multiCardGroupCompare :: (SemanticToken a) => Options -> [MultiCard a] -> [a] -> [(Bool, (MultiCard a, [String]))] +multiCardGroupCompare opt ls rs + | length rs >= length ls = zipWith (tokensZip opt) ls rs + | otherwise = [ (False, ([AnyCard], [])) ] + + +tokensZip :: (SemanticToken a) => Options -> MultiCard a -> a -> (Bool, (MultiCard a, [String])) +tokensZip opt l r + | multiCardMatch opt l r = (True, (l, [tkToString r])) + | otherwise = (False, ([AnyCard],[] )) + + +multiCardMatch :: (SemanticToken t) => Options -> MultiCard t -> t -> Bool +multiCardMatch opt m t = any (\w -> wildCardMatch opt w t) m + +wildCardMatch :: (SemanticToken t) => Options -> WildCard t -> t -> Bool +wildCardMatch _ AnyCard _ = True +wildCardMatch _ (IdentifCard _) t = tkIsIdentifier t +wildCardMatch _ KeyWordCard t = tkIsKeyword t +wildCardMatch _ StringCard t = tkIsString t +wildCardMatch _ CharCard t = tkIsChar t +wildCardMatch _ LiteralCard t = tkIsString t || tkIsChar t +wildCardMatch _ NumberCard t = tkIsNumber t +wildCardMatch _ OctCard t = tkIsNumber t && case tkToString t of ('0':d: _) -> isDigit d; _ -> False +wildCardMatch _ HexCard t = tkIsNumber t && case tkToString t of ('0':'x':_) -> True; _ -> False +wildCardMatch opt (TokenCard l) r + | tkIsIdentifier l && tkIsIdentifier r = + case () of + _ | edit_dist opt -> tkToString l ~== tkToString r + | word_match opt -> tkToString l == tkToString r + | prefix_match opt -> tkToString l `isPrefixOf` tkToString r + | suffix_match opt -> tkToString l `isSuffixOf` tkToString r + | otherwise -> tkToString l `isInfixOf` tkToString r + | tkIsString l && tkIsString r = + case () of + _ | edit_dist opt -> ls ~== rs + | word_match opt -> ls == rs + | prefix_match opt -> ls `isPrefixOf` rs + | suffix_match opt -> ls `isSuffixOf` rs + | otherwise -> ls `isInfixOf` rs + where ls = rmQuote $ trim (tkToString l) + rs = rmQuote $ trim (tkToString r) + | otherwise = l `tkEquivalent` r + diff --git a/src/CGrep/Semantic/Cpp/Token.hs b/src/CGrep/Semantic/Cpp/Token.hs deleted file mode 100644 --- a/src/CGrep/Semantic/Cpp/Token.hs +++ /dev/null @@ -1,381 +0,0 @@ --- --- Copyright (c) 2012-2013 Bonelli Nicola --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --- - -{-# LANGUAGE ViewPatterns #-} - -module CGrep.Semantic.Cpp.Token(Token(..), TokenFilter(..), - Offset, tokenizer, tokenFilter, tokenCompare, - isIdentifier, isKeyword, isDirective, isLiteralNumber, - isHeaderName, isString, isChar, isOperOrPunct - ) where - -import Data.Char -import Data.Maybe -import Control.Monad -import Data.Array.Unboxed - -import qualified Data.HashSet as HS -import qualified Data.HashMap.Strict as HM -import qualified Data.ByteString.Char8 as C - -import CGrep.Semantic.Token - -data TokenizerState = TokenizerState Source {-# UNPACK #-} !Offset !CppState -type Source = C.ByteString -type Offset = Int - - -data Token = - TokenIdentifier { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | - TokenDirective { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | - TokenKeyword { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | - TokenNumber { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | - TokenHeaderName { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | - TokenString { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | - TokenChar { toString :: !String, toOffset :: {-# UNPACK #-} !Int } | - TokenOperOrPunct { toString :: !String, toOffset :: {-# UNPACK #-} !Int } - deriving (Show, Eq, Ord) - - -data TokenFilter = TokenFilter - { filtIdentifier :: !Bool - , filtDirective :: !Bool - , filtKeyword :: !Bool - , filtHeader :: !Bool - , filtString :: !Bool - , filtNumber :: !Bool - , filtChar :: !Bool - , filtOper :: !Bool - } deriving (Eq) - - -instance SemanticToken Token where - tkIsIdentifier = isIdentifier - tkIsString = isString - tkIsChar = isChar - tkIsNumber = isLiteralNumber - tkIsKeyword = isKeyword - tkEquivalent = tokenCompare - tkToString = toString - tkToOffset = toOffset - tkToIdentif = TokenIdentifier - - --- Tokenize the source code in a list of Token --- Precondition: the C++ source code must be well-formed --- - -tokenizer :: Source -> [Token] -tokenizer xs = runGetToken (TokenizerState ys n Null) - where (ys, n) = dropWhite xs - - -tokenFilter :: TokenFilter -> Token -> Bool -tokenFilter filt (TokenIdentifier{}) = filtIdentifier filt -tokenFilter filt (TokenDirective{}) = filtDirective filt -tokenFilter filt (TokenKeyword{}) = filtKeyword filt -tokenFilter filt (TokenHeaderName{}) = filtHeader filt -tokenFilter filt (TokenNumber{}) = filtNumber filt -tokenFilter filt (TokenString{}) = filtString filt -tokenFilter filt (TokenChar{}) = filtChar filt -tokenFilter filt (TokenOperOrPunct{}) = filtOper filt - - -tokenCompare :: Token -> Token -> Bool -tokenCompare (TokenIdentifier { toString = l }) (TokenIdentifier { toString = r }) = l == r -tokenCompare (TokenDirective { toString = l }) (TokenDirective { toString = r }) = l == r -tokenCompare (TokenKeyword { toString = l }) (TokenKeyword { toString = r }) = l == r -tokenCompare (TokenNumber { toString = l }) (TokenNumber { toString = r }) = l == r -tokenCompare (TokenHeaderName { toString = l }) (TokenHeaderName { toString = r }) = l == r -tokenCompare (TokenString { toString = l }) (TokenString { toString = r }) = l == r -tokenCompare (TokenChar { toString = l }) (TokenChar { toString = r }) = l == r -tokenCompare (TokenOperOrPunct{ toString = l }) (TokenOperOrPunct{ toString = r }) = l == r -tokenCompare _ _ = False - - -isIdentifier :: Token -> Bool -isIdentifier (TokenIdentifier {}) = True -isIdentifier _ = False - - -isKeyword :: Token -> Bool -isKeyword (TokenKeyword {}) = True -isKeyword _ = False - - -isDirective :: Token -> Bool -isDirective (TokenDirective {}) = True -isDirective _ = False - - -isLiteralNumber :: Token -> Bool -isLiteralNumber (TokenNumber {}) = True -isLiteralNumber _ = False - - -isHeaderName :: Token -> Bool -isHeaderName (TokenHeaderName {}) = True -isHeaderName _ = False - - -isString :: Token -> Bool -isString (TokenString {}) = True -isString _ = False - - -isChar :: Token -> Bool -isChar (TokenChar {}) = True -isChar _ = False - - -isOperOrPunct :: Token -> Bool -isOperOrPunct (TokenOperOrPunct {}) = True -isOperOrPunct _ = False - - -isIdentifierChar' :: Char -> Bool -isIdentifierChar' = ((listArray ('\0', '\255') (map (\c -> isAlphaNum c || c == '_' || c == '$') ['\0'..'\255']) :: UArray Char Bool) !) -- GNU allows $ in identifier - - -isChar' :: Char -> Bool -isChar'= ((listArray ('\0', '\255') (map (\c -> isSpace c || c == '\\') ['\0'..'\255']) :: UArray Char Bool) !) - --- Drop leading whitespace and count them --- - -{-# INLINE dropWhite #-} - -dropWhite :: Source -> (Source, Offset) -dropWhite xs = (xs', doff) - where xs' = C.dropWhile isChar' xs - doff = fromIntegral $ C.length xs - C.length xs' - - -data CppState = Null | Hash | Include | Define | Undef | If | Ifdef | Ifndef | Elif | Else | Endif | - Line | Error | Pragma - deriving (Show, Eq) - - -directiveKeys :: HM.HashMap String CppState -directiveKeys = HM.fromList [ ("#", Hash), - ("include", Include), - ("include_next", Include), - ("define", Define), - ("undef", Undef), - ("if", If), - ("ifdef", Ifdef), - ("ifndef", Ifndef), - ("elif", Elif), - ("else", Else), - ("endif", Null), - ("line", Line), - ("error", Error), - ("pragma", Pragma) ] - - -nextCppState :: String -> CppState -> CppState -nextCppState str pps - | Hash <- pps = fromMaybe Null (HM.lookup str directiveKeys) - | otherwise = if str == "#" then Hash else Null - - -runGetToken :: TokenizerState -> [Token] - -runGetToken (TokenizerState (C.uncons -> Nothing) _ _) = [] -runGetToken tstate = token : runGetToken ns - where (token, ns) = getToken tstate - - -getToken :: TokenizerState -> (Token, TokenizerState) - -getToken (TokenizerState (C.uncons -> Nothing) _ _) = error "getToken: internal error" -getToken (TokenizerState xs off state) = - let token = fromJust $ - getTokenDirective xs state `mplus` - getTokenHeaderName xs state `mplus` - getTokenNumber xs state `mplus` - getTokenString xs state `mplus` - getTokenChar xs state `mplus` - getTokenIdOrKeyword xs state `mplus` - getTokenOpOrPunct xs state - tstring = toString token - len = fromIntegral $ length tstring - (xs', w) = dropWhite $ C.drop (fromIntegral len) xs - in - (token { toOffset = off }, (TokenizerState xs' (off + len + w) (nextCppState tstring state))) - - -getTokenIdOrKeyword, getTokenNumber, - getTokenHeaderName, getTokenString, - getTokenChar, getTokenOpOrPunct, - getTokenDirective :: Source -> CppState -> Maybe Token - - -getTokenDirective xs state - | state == Hash = Just (TokenDirective name 0) - | otherwise = Nothing - where name = C.unpack $ C.takeWhile isIdentifierChar' xs - - -getTokenHeaderName (C.uncons -> Nothing) _ = error "getTokenHeaderName: internal error" -getTokenHeaderName xs@(C.uncons -> Just (x,_)) state - | state /= Include = Nothing - | x == '<' = Just $ TokenHeaderName (getLiteral '<' '>' False xs) 0 - | x == '"' = Just $ TokenHeaderName (getLiteral '"' '"' False xs) 0 - | otherwise = Just $ TokenHeaderName (C.unpack $ C.takeWhile isIdentifierChar' xs) 0 - -getTokenHeaderName _ _ = undefined - - -getTokenNumber ys@(C.uncons -> Just (x,_)) _ - | x == '.' || isDigit x = let ts = getNumber ys NumberNothing in - case ts of - "" -> Nothing - "." -> Nothing - _ -> Just $ TokenNumber ts 0 - | otherwise = Nothing -getTokenNumber (C.uncons -> Nothing) _ = Nothing -getTokenNumber _ _ = undefined - - -validHexSet, validOctSet, validDecSet :: HS.HashSet Char - -validHexSet = HS.fromList "0123456789abcdefABCDEFxX" -validOctSet = HS.fromList "01234567" -validDecSet = HS.fromList "0123456789" - -data NumberState = NumberNothing | NumberOHF | NumberDec | NumberOct | NumberHex | NumberMayBeFloat | NumberFloat | NumberExp - deriving (Show,Eq,Enum) - -getNumber :: C.ByteString -> NumberState -> String --- getNumber xs s | trace ("state = " ++ show s) False = undefined - -getNumber (C.uncons -> Nothing) _ = "" -getNumber (C.uncons -> Just (x,xs)) state - | state == NumberNothing = case () of _ - | x == '0' -> x : getNumber xs NumberOHF - | x == '.' -> x : getNumber xs NumberMayBeFloat - | isDigit x -> x : getNumber xs NumberDec - | otherwise -> "" - | state == NumberOHF = case () of _ - | x `HS.member` validHexSet -> x : getNumber xs NumberHex - | x == '.' -> x : getNumber xs NumberMayBeFloat - | isDigit x -> x : getNumber xs NumberOct - | otherwise -> "" - - | state == NumberDec = case () of _ - | x `HS.member` validDecSet -> x : getNumber xs NumberDec - | x == '.' -> x : getNumber xs NumberMayBeFloat - | x == 'e' || x == 'E' -> x : getNumber xs NumberExp - | otherwise -> "" - - | state == NumberOct = case () of _ - | x `HS.member` validOctSet -> x : getNumber xs NumberOct - | otherwise -> "" - - | state == NumberHex = case () of _ - | x `HS.member` validHexSet -> x : getNumber xs NumberHex - | otherwise -> "" - - | state == NumberMayBeFloat = case () of _ - | x `HS.member` validDecSet -> x : getNumber xs NumberFloat - | otherwise -> "" - - | state == NumberFloat = case () of _ - | x `HS.member` validDecSet -> x : getNumber xs NumberFloat - | x == 'e' || x == 'E' -> x : getNumber xs NumberExp - | otherwise -> "" - - | state == NumberExp = case () of _ - | x `HS.member` validDecSet -> x : getNumber xs NumberExp - | x == '+' || x == '-' -> x : getNumber xs NumberExp - | otherwise -> "" - -getNumber _ _ = undefined - - -getTokenString xs@(C.uncons -> Just (x,_)) _ - | x == '"' = Just $ TokenString (getLiteral '"' '"' False xs) 0 - | otherwise = Nothing -getTokenString (C.uncons -> Nothing) _ = Nothing -getTokenString _ _ = Nothing - - -getTokenChar xs@(C.uncons -> Just (x,_)) _ - | x == '\'' = Just $ TokenChar (getLiteral '\'' '\'' False xs) 0 - | otherwise = Nothing -getTokenChar (C.uncons -> Nothing) _ = Nothing -getTokenChar _ _ = Nothing - - -getTokenIdOrKeyword xs@(C.uncons -> Just (x,_)) _ - | not $ isIdentifierChar' x = Nothing - | name `HS.member` keywords = Just $ TokenKeyword name 0 - | otherwise = Just $ TokenIdentifier name 0 - where name = C.unpack $ C.takeWhile isIdentifierChar' xs -getTokenIdOrKeyword (C.uncons -> Nothing) _ = Nothing -getTokenIdOrKeyword _ _ = Nothing - - -getTokenOpOrPunct source _ = go source (min 4 (C.length source)) - where go _ 0 - | C.length source > 0 = error $ "operator or punct: error " ++ show source - | otherwise = Nothing - go src len - | sub `HS.member` operOrPunct = Just $ TokenOperOrPunct sub 0 - | otherwise = go src (len-1) - where sub = C.unpack (C.take len src) - - -getLiteral :: Char -> Char -> Bool -> C.ByteString -> String -getLiteral _ _ _ (C.uncons -> Nothing) = [] -getLiteral b e False ys@(C.uncons -> Just (x,xs)) - | x == b = b : getLiteral b e True xs - | otherwise = error $ "literal: error " ++ C.unpack ys -getLiteral b e True (C.uncons -> Just (x,xs)) - | x == e = [e] - | x == '\\' = '\\' : x' : getLiteral b e True xs' - | otherwise = x : getLiteral b e True xs - where - (C.uncons -> Just(x',xs')) = xs -getLiteral _ _ _ _ = [] - - -operOrPunct :: HS.HashSet String -operOrPunct = HS.fromList [ "{","}","[","]","#","(",")",";",":","?",".","+","-","*", - "/","%","^","&","|","~","!","=","<",">","," , - "##", "<:", ":>", "<%", "%>", "%:", "::", ".*", "+=", "-=", - "*=", "/=", "%=", "^=", "&=", "|=", "<<", ">>", ">=", "<=", - "&&", "||", "==", "!=", "++", "--", "->", "//", "/*", "*/", - "...", "<<=", ">>=", "->*", - "%:%:" ] - -keywords :: HS.HashSet String -keywords = HS.fromList ["alignas", "continue", "friend", "alignof", "decltype", "goto", "asm", - "default", "if", "auto", "delete", "inline", "bool", "do", "int", "break", - "double", "long", "case", "dynamic_cast", "mutable", "catch", "else", - "namespace", "char", "enum", "new", "char16_t", "explicit", "noexcept", - "char32_t", "export", "nullptr", "class", "extern", "operator", "const", - "false", "private", "constexpr", "float", "protected", "const_cast", "for", - "public", "register", "true", "reinterpret_cast", "try", "return", "typedef", - "short", "typeid", "signed", "typename", "sizeof", "union", "static", "unsigned", - "static_assert", "using", "static_cast", "virtual", "struct", "void", "switch", - "volatile", "template", "wchar_t", "this", "while", "thread_local", "throw", - "and", "and_eq", "bitand", "bitor", "compl", "not", "not_eq", "or", "or_eq", - "xor", "xor_eq"] - diff --git a/src/CGrep/Semantic/Generic/Token.hs b/src/CGrep/Semantic/Generic/Token.hs deleted file mode 100644 --- a/src/CGrep/Semantic/Generic/Token.hs +++ /dev/null @@ -1,213 +0,0 @@ --- --- Copyright (c) 2013 Bonelli Nicola --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --- - -{-# LANGUAGE FlexibleInstances #-} - - -module CGrep.Semantic.Generic.Token (tokenizer, Token(..)) where - -import qualified Data.ByteString.Char8 as C -import qualified Data.DList as DL - -import Data.Char -import Data.Array.Unboxed - -import CGrep.Semantic.Token -import CGrep.Types - -type DString = DL.DList Char - - -data TokenState = - StateSpace | - StateAlpha | - StateDigit | - StateBracket | - StateLit1 | - StateLit2 | - StateOther - deriving (Eq, Enum, Show) - - -data Token = - TokenAlpha { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } | - TokenDigit { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } | - TokenBracket { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } | - TokenLiteral { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } | - TokenOther { toString :: !String, toOffset :: {-# UNPACK #-} !Offset } - deriving (Show, Eq, Ord) - - -instance SemanticToken Token where - tkIsIdentifier = _isTokenAlpha - tkIsString = _isTokenLiteral - tkIsChar = _isTokenLiteral - tkIsNumber = _isTokenDigit - tkIsKeyword = const False - tkEquivalent = tokenCompare - tkToString = toString - tkToOffset = toOffset - tkToIdentif = TokenAlpha - - -_isTokenAlpha, _isTokenDigit, _isTokenBracket, _isTokenOther, _isTokenLiteral :: Token -> Bool - -_isTokenAlpha (TokenAlpha _ _) = True -_isTokenAlpha _ = False - -_isTokenDigit (TokenDigit _ _) = True -_isTokenDigit _ = False - -_isTokenBracket (TokenBracket _ _) = True -_isTokenBracket _ = False - -_isTokenLiteral (TokenLiteral _ _) = True -_isTokenLiteral _ = False - -_isTokenOther (TokenOther _ _) = True -_isTokenOther _ = False - - -tokenCompare :: Token -> Token -> Bool -tokenCompare (TokenAlpha { toString = l }) (TokenAlpha { toString = r }) = l == r -tokenCompare (TokenDigit { toString = l }) (TokenDigit { toString = r }) = l == r -tokenCompare (TokenLiteral { toString = l }) (TokenLiteral { toString = r }) = l == r -tokenCompare (TokenBracket { toString = l }) (TokenBracket { toString = r }) = l == r -tokenCompare (TokenOther { toString = l }) (TokenOther { toString = r }) = l == r -tokenCompare _ _ = False - - -data TokenAccum = TokenAccum !TokenState {-# UNPACK #-} !Offset {-# UNPACK #-} !Int DString (DL.DList Token) - - -isCharNumberLT :: UArray Char Bool -isCharNumberLT = - listArray ('\0', '\255') - (map (\c -> isHexDigit c || c `elem` ".xX") ['\0'..'\255']) - - -isSpaceLT :: UArray Char Bool -isSpaceLT = - listArray ('\0', '\255') - (map isSpace ['\0'..'\255']) - -isAlphaLT :: UArray Char Bool -isAlphaLT = - listArray ('\0', '\255') - (map (\c -> isAlpha c || c == '_') ['\0'..'\255']) - -isAlphaNumLT :: UArray Char Bool -isAlphaNumLT = - listArray ('\0', '\255') - (map (\c -> isAlphaNum c || c == '_' || c == '\'') ['\0'..'\255']) - -isDigitLT :: UArray Char Bool -isDigitLT = - listArray ('\0', '\255') - (map isDigit ['\0'..'\255']) - -isBracketLT :: UArray Char Bool -isBracketLT = - listArray ('\0', '\255') - (map (`elem` "{[()]}") ['\0'..'\255']) - - -{-# INLINE mkToken #-} - - -mkToken :: (String -> Offset -> Token) -> Offset -> DString -> Token -mkToken ctor off ds = ctor str (off - length str) - where str = DL.toList ds - - -mkTokenCtor :: TokenState -> String -> Offset -> Token -mkTokenCtor StateSpace = TokenOther -mkTokenCtor StateAlpha = TokenAlpha -mkTokenCtor StateDigit = TokenDigit -mkTokenCtor StateBracket = TokenBracket -mkTokenCtor StateLit1 = TokenLiteral -mkTokenCtor StateLit2 = TokenLiteral -mkTokenCtor StateOther = TokenOther - - -tokenizer :: Text8 -> [Token] -tokenizer xs = (\(TokenAccum ss off _ acc out) -> - DL.toList (if null (DL.toList acc) then out - else out `DL.snoc` mkToken (mkTokenCtor ss) off acc)) $ C.foldl' tokens' (TokenAccum StateSpace 0 0 DL.empty DL.empty) xs - where tokens' :: TokenAccum -> Char -> TokenAccum - tokens' (TokenAccum StateSpace off _ _ out) x = - case () of - _ | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty out - | x == '\'' -> TokenAccum StateLit1 (off+1) 0 (DL.singleton x) out - | x == '"' -> TokenAccum StateLit2 (off+1) 0 (DL.singleton x) out - | isAlphaLT ! x -> TokenAccum StateAlpha (off+1) 0 (DL.singleton x) out - | isDigitLT ! x -> TokenAccum StateDigit (off+1) 0 (DL.singleton x) out - | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) out - | otherwise -> TokenAccum StateOther (off+1) 0 (DL.singleton x) out - - tokens' (TokenAccum StateAlpha off _ acc out) x = - case () of - _ | isAlphaNumLT ! x -> TokenAccum StateAlpha (off+1) 0 (acc `DL.snoc` x) out - | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenAlpha off acc) - | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenAlpha off acc) - | otherwise -> TokenAccum StateOther (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenAlpha off acc) - - tokens' (TokenAccum StateDigit off _ acc out) x = - case () of - _ | isCharNumberLT ! x -> TokenAccum StateDigit (off+1) 0 (acc `DL.snoc` x) out - | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenDigit off acc) - | isAlphaLT ! x -> TokenAccum StateAlpha (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenDigit off acc) - | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenDigit off acc) - | otherwise -> TokenAccum StateOther (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenDigit off acc) - - tokens' (TokenAccum StateLit1 off skip acc out) x = - case () of - _ | skip > 0 -> TokenAccum StateLit1 (off+1) (skip-1) (acc `DL.snoc` x) out - | x == '\\' -> TokenAccum StateLit1 (off+1) 1 (acc `DL.snoc` x) out - | x == '\'' -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenLiteral (off+1) (acc `DL.snoc` '\'')) - | otherwise -> TokenAccum StateLit1 (off+1) 0 (acc `DL.snoc` x) out - - tokens' (TokenAccum StateLit2 off skip acc out) x = - case () of - _ | skip > 0 -> TokenAccum StateLit2 (off+1) (skip-1) (acc `DL.snoc` x) out - | x == '\\' -> TokenAccum StateLit2 (off+1) 1 (acc `DL.snoc` x) out - | x == '"' -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenLiteral (off+1) (acc `DL.snoc` '"')) - | otherwise -> TokenAccum StateLit2 (off+1) 0 (acc `DL.snoc` x) out - - tokens' (TokenAccum StateBracket off _ acc out) x = - case () of - _ | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenBracket off acc) - | isAlphaLT ! x -> TokenAccum StateAlpha (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) - | isDigitLT ! x -> TokenAccum StateDigit (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) - | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) - | x == '\'' -> TokenAccum StateLit1 (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) - | x == '"' -> TokenAccum StateLit2 (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) - | otherwise -> TokenAccum StateOther (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) - - tokens' (TokenAccum StateOther off _ acc out) x = - case () of - _ | isSpaceLT ! x -> TokenAccum StateSpace (off+1) 0 DL.empty (out `DL.snoc` mkToken TokenOther off acc) - | isAlphaLT ! x -> TokenAccum StateAlpha (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenOther off acc) - | isDigitLT ! x -> if DL.toList acc == "." - then TokenAccum StateDigit (off+1) 0 (acc `DL.snoc` x) out - else TokenAccum StateDigit (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenOther off acc) - | isBracketLT ! x -> TokenAccum StateBracket (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenOther off acc) - | x == '\'' -> TokenAccum StateLit1 (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) - | x == '"' -> TokenAccum StateLit2 (off+1) 0 (DL.singleton x) (out `DL.snoc` mkToken TokenBracket off acc) - | otherwise -> TokenAccum StateOther (off+1) 0 (acc `DL.snoc` x) out - diff --git a/src/CGrep/Semantic/Token.hs b/src/CGrep/Semantic/Token.hs deleted file mode 100644 --- a/src/CGrep/Semantic/Token.hs +++ /dev/null @@ -1,32 +0,0 @@ --- --- Copyright (c) 2013 Bonelli Nicola --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --- - -module CGrep.Semantic.Token (SemanticToken(..)) where - - -class (Show t, Ord t) => SemanticToken t where - tkIsIdentifier :: t -> Bool - tkIsString :: t -> Bool - tkIsChar :: t -> Bool - tkIsNumber :: t -> Bool - tkIsKeyword :: t -> Bool - tkEquivalent :: t -> t -> Bool - tkToString :: t -> String - tkToOffset :: t -> Int - tkToIdentif :: String -> Int -> t - diff --git a/src/CGrep/Semantic/WildCard.hs b/src/CGrep/Semantic/WildCard.hs deleted file mode 100644 --- a/src/CGrep/Semantic/WildCard.hs +++ /dev/null @@ -1,220 +0,0 @@ --- --- Copyright (c) 2013 Bonelli Nicola --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --- - -module CGrep.Semantic.WildCard (WildCard(..), MultiCard, - mkWildCardFromToken, - combineMultiCard, - filterTokensWithMultiCards, - wildCardMatch, - multiCardMatch) where - -import qualified Data.Map as M - -import CGrep.Common -import CGrep.Distance -import CGrep.Semantic.Token - -import Data.Char -import Data.List -import Options -import Util - - -data WildCard a = - TokenCard a | - AnyCard | - KeyWordCard | - NumberCard | - OctCard | - HexCard | - StringCard | - LiteralCard | - CharCard | - IdentifCard String - deriving (Show, Eq, Ord) - - - -type MultiCard a = [WildCard a] - - -wildCardMap :: M.Map String (WildCard a) -wildCardMap = M.fromList - [ - ("ANY", AnyCard ), - ("KEY", KeyWordCard ), - ("OCT", OctCard ), - ("HEX", HexCard ), - ("NUM", NumberCard ), - ("CHR", CharCard ), - ("STR", StringCard ), - ("LIT", StringCard ) - ] - - -mkWildCardFromToken :: (SemanticToken a) => a -> WildCard a -mkWildCardFromToken t - | tkIsIdentifier t = case () of - _ | Just wc <- M.lookup str wildCardMap -> wc - | isWildCardIdentif str -> IdentifCard str - | otherwise -> TokenCard $ tkToIdentif (rmWildCardEscape str) (tkToOffset t) - where str = tkToString t - - | otherwise = TokenCard t - - -combineMultiCard :: (SemanticToken a) => [MultiCard a] -> [MultiCard a] -combineMultiCard (m1:r@(m2:m3:ms)) - | [TokenCard b] <- m2, tkToString b == "OR" = combineMultiCard $ (m1++m3):ms - | otherwise = m1 : combineMultiCard r -combineMultiCard [m1,m2] = [m1,m2] -combineMultiCard [m1] = [m1] -combineMultiCard [] = [] - - -filterTokensWithMultiCards :: (SemanticToken a) => Options -> [MultiCard a] -> [a] -> [a] -filterTokensWithMultiCards opt ws = filterTokensWithMultiCards' opt (spanOptionalCards ws) - - -filterTokensWithMultiCards' :: (SemanticToken a) => Options -> [[MultiCard a]] -> [a] -> [a] -filterTokensWithMultiCards' _ [] _ = [] -filterTokensWithMultiCards' opt (g:gs) ts = - concatMap (take grpLen . (`drop` ts)) (findIndices (multiCardCompare opt g) grp) ++ - filterTokensWithMultiCards' opt gs ts - where grp = spanGroup grpLen ts - grpLen = length g - - -spanOptionalCards :: [MultiCard a] -> [[MultiCard a]] -spanOptionalCards wc = map (`filterCardIndicies` wc') idx - where wc' = zip [0..] wc - idx = subsequences $ - findIndices (\w -> case w of - [IdentifCard ('$':_)] -> True - _ -> False) wc - - -filterCardIndicies :: [Int] -> [(Int, MultiCard a)] -> [MultiCard a] -filterCardIndicies ns ps = map snd $ filter (\(n, _) -> n `notElem` ns) ps - - -multiCardCompare :: (SemanticToken a) => Options -> [MultiCard a] -> [a] -> Bool -multiCardCompare opt l r = - multiCardCompareAll ts && multiCardCheckOccurences ts - where ts = multiCardGroupCompare opt l r - - -isWildCardIdentif :: String -> Bool -isWildCardIdentif s = - case () of - _ | (x:y:_) <- s -> wprefix x && isNumber y - | [x] <- s -> wprefix x - | otherwise -> error "isWildCardIdentif" - where wprefix x = x == '$' || x == '_' - - -rmWildCardEscape :: String -> String -rmWildCardEscape ('$':xs) = xs -rmWildCardEscape ('_':xs) = xs -rmWildCardEscape xs = xs - - -{-# INLINE multiCardCompareAll #-} - -multiCardCompareAll :: [(Bool, (MultiCard a, [String]))] -> Bool -multiCardCompareAll = all fst - - -{-# INLINE multiCardCheckOccurences #-} - --- Note: pattern $ and _ match any token, whereas $1 $2 (_1 _2 etc.) match tokens --- that must compare equal in the respective occurrences --- - -multiCardCheckOccurences :: (SemanticToken a) => [(Bool, (MultiCard a, [String]))] -> Bool -multiCardCheckOccurences ts = M.foldr (\xs r -> r && all (== head xs) xs) True m - where m = M.mapWithKey (\k xs -> - case k of - [IdentifCard "_0"] -> xs - [IdentifCard "_1"] -> xs - [IdentifCard "_2"] -> xs - [IdentifCard "_3"] -> xs - [IdentifCard "_4"] -> xs - [IdentifCard "_5"] -> xs - [IdentifCard "_6"] -> xs - [IdentifCard "_7"] -> xs - [IdentifCard "_8"] -> xs - [IdentifCard "_9"] -> xs - [IdentifCard "$0"] -> xs - [IdentifCard "$1"] -> xs - [IdentifCard "$2"] -> xs - [IdentifCard "$3"] -> xs - [IdentifCard "$4"] -> xs - [IdentifCard "$5"] -> xs - [IdentifCard "$6"] -> xs - [IdentifCard "$7"] -> xs - [IdentifCard "$8"] -> xs - [IdentifCard "$9"] -> xs - _ -> [] - ) $ M.fromListWith (++) (map snd ts) - - -multiCardGroupCompare :: (SemanticToken a) => Options -> [MultiCard a] -> [a] -> [(Bool, (MultiCard a, [String]))] -multiCardGroupCompare opt ls rs - | length rs >= length ls = zipWith (tokensZip opt) ls rs - | otherwise = [ (False, ([AnyCard], [])) ] - - -tokensZip :: (SemanticToken a) => Options -> MultiCard a -> a -> (Bool, (MultiCard a, [String])) -tokensZip opt l r - | multiCardMatch opt l r = (True, (l, [tkToString r])) - | otherwise = (False, ([AnyCard],[] )) - - -multiCardMatch :: (SemanticToken t) => Options -> MultiCard t -> t -> Bool -multiCardMatch opt m t = any (\w -> wildCardMatch opt w t) m - -wildCardMatch :: (SemanticToken t) => Options -> WildCard t -> t -> Bool -wildCardMatch _ AnyCard _ = True -wildCardMatch _ (IdentifCard _) t = tkIsIdentifier t -wildCardMatch _ KeyWordCard t = tkIsKeyword t -wildCardMatch _ StringCard t = tkIsString t -wildCardMatch _ CharCard t = tkIsChar t -wildCardMatch _ LiteralCard t = tkIsString t || tkIsChar t -wildCardMatch _ NumberCard t = tkIsNumber t -wildCardMatch _ OctCard t = tkIsNumber t && case tkToString t of ('0':d: _) -> isDigit d; _ -> False -wildCardMatch _ HexCard t = tkIsNumber t && case tkToString t of ('0':'x':_) -> True; _ -> False -wildCardMatch opt (TokenCard l) r - | tkIsIdentifier l && tkIsIdentifier r = - case () of - _ | edit_dist opt -> tkToString l ~== tkToString r - | word_match opt -> tkToString l == tkToString r - | prefix_match opt -> tkToString l `isPrefixOf` tkToString r - | suffix_match opt -> tkToString l `isSuffixOf` tkToString r - | otherwise -> tkToString l `isInfixOf` tkToString r - | tkIsString l && tkIsString r = - case () of - _ | edit_dist opt -> ls ~== rs - | word_match opt -> ls == rs - | prefix_match opt -> ls `isPrefixOf` rs - | suffix_match opt -> ls `isSuffixOf` rs - | otherwise -> ls `isInfixOf` rs - where ls = rmQuote $ trim (tkToString l) - rs = rmQuote $ trim (tkToString r) - | otherwise = l `tkEquivalent` r - diff --git a/src/CGrep/Strategy/BoyerMoore.hs b/src/CGrep/Strategy/BoyerMoore.hs --- a/src/CGrep/Strategy/BoyerMoore.hs +++ b/src/CGrep/Strategy/BoyerMoore.hs @@ -40,41 +40,35 @@ search :: FilePath -> [Text8] -> ReaderT Options IO [Output] -search f ps = do +search f patterns = do - opt <- ask + opt <- ask + text <- liftIO $ getTargetContents f let filename = getTargetName f - text <- liftIO $ getTargetContents f - -- transform text - let text' = ignoreCase opt text - - -- put banners... - - putStrLevel1 $ "strategy : running string search on " ++ filename ++ "..." - - runSearch filename (quickSearch opt ps text') $ do - - -- context filter - - let text'' = contextFilter (getFileLang opt filename) (mkContextFilter opt) text' + let [text''', _ , text', _] = scanr ($) text [ expandMultiline opt + , contextFilter (getFileLang opt filename) (mkContextFilter opt) + , ignoreCase opt + ] - -- expand multi-line + putStrLevel1 $ "strategy : running Boyer-Moore search on " ++ filename ++ "..." - text''' = expandMultiline opt text'' + runQuickSearch filename (quickSearch opt patterns text') $ do -- search for matching tokens - tokens = map (A.second C.unpack) $ ps >>= (\p -> map (\i -> (i,p)) (p `SC.nonOverlappingIndices` text''')) + let tokens = map (A.second C.unpack) $ patterns >>= (\p -> map (\i -> (i,p)) (p `SC.nonOverlappingIndices` text''')) -- filter exact/partial matching tokens tokens' = if word_match opt || prefix_match opt || suffix_match opt then filter (checkToken opt text''') tokens else tokens + + -- print banners... putStrLevel2 $ "tokens : " ++ show tokens putStrLevel2 $ "tokens' : " ++ show tokens' diff --git a/src/CGrep/Strategy/Cpp/Semantic.hs b/src/CGrep/Strategy/Cpp/Semantic.hs --- a/src/CGrep/Strategy/Cpp/Semantic.hs +++ b/src/CGrep/Strategy/Cpp/Semantic.hs @@ -19,7 +19,7 @@ module CGrep.Strategy.Cpp.Semantic (search) where import qualified Data.ByteString.Char8 as C -import qualified CGrep.Semantic.Cpp.Token as Cpp +import qualified CGrep.Parser.Cpp.Token as Cpp import Control.Monad.Trans.Reader import Control.Monad.IO.Class @@ -32,7 +32,7 @@ import CGrep.Common import CGrep.Output -import CGrep.Semantic.WildCard +import CGrep.Parser.WildCard import Options import Debug @@ -40,61 +40,57 @@ search :: FilePath -> [Text8] -> ReaderT Options IO [Output] -search f ps = do +search f patterns = do - opt <- ask + opt <- ask + text <- liftIO $ getTargetContents f let filename = getTargetName f - text <- liftIO $ getTargetContents f - -- transform text - let text' = ignoreCase opt text - - filt = (mkContextFilter opt) { getFilterComment = False } + let filt = (mkContextFilter opt) { getFilterComment = False } + text' = ignoreCase opt text -- pre-process patterns - patterns = map (Cpp.tokenizer . contextFilter (Just Cpp) filt) ps -- [ [t1,t2,..], [t1,t2...] ] - patterns' = map (map mkWildCardFromToken) patterns -- [ [w1,w2,..], [w1,w2,..] ] - patterns'' = map (combineMultiCard . map (:[])) patterns' -- [ [m1,m2,..], [m1,m2,..] ] == [ [ [w1], [w2],..], [[w1],[w2],..]] + patterns' = map (Cpp.tokenizer . contextFilter (Just Cpp) filt) patterns -- [ [t1,t2,..], [t1,t2...] ] + patterns'' = map (map mkWildCardFromToken) patterns' -- [ [w1,w2,..], [w1,w2,..] ] + patterns''' = map (combineMultiCard . map (:[])) patterns'' -- [ [m1,m2,..], [m1,m2,..] ] == [ [ [w1], [w2],..], [[w1],[w2],..]] - -- quick Search... - ps' = (mapMaybe (\x -> case x of - TokenCard (Cpp.TokenChar xs _) -> Just (rmQuote $ trim xs) - TokenCard (Cpp.TokenString xs _) -> Just (rmQuote $ trim xs) - TokenCard (Cpp.TokenIdentifier "OR" _) -> Nothing - TokenCard t -> Just (Cpp.toString t) - _ -> Nothing - ) . concat) patterns' + -- quickSearch + identif = (mapMaybe (\x -> case x of + TokenCard (Cpp.TokenChar xs _) -> Just (rmQuote $ trim xs) + TokenCard (Cpp.TokenString xs _) -> Just (rmQuote $ trim xs) + TokenCard (Cpp.TokenIdentifier "OR" _) -> Nothing + TokenCard t -> Just (Cpp.toString t) + _ -> Nothing + ) . concat) patterns'' + -- put banners... putStrLevel1 $ "strategy : running C/C++ semantic search on " ++ filename ++ "..." - putStrLevel2 $ "wildcards : " ++ show patterns' - putStrLevel2 $ "multicards: " ++ show patterns'' - putStrLevel2 $ "identif : " ++ show ps' - - runSearch filename (quickSearch opt (map C.pack ps') text') $ do - -- context filter - - let text'' = contextFilter (getFileLang opt filename) filt text' + putStrLevel2 $ "wildcards : " ++ show patterns'' + putStrLevel2 $ "multicards: " ++ show patterns''' + putStrLevel2 $ "identif : " ++ show identif - -- expand multi-line + runQuickSearch filename (quickSearch opt (map C.pack identif) text') $ do - text''' = expandMultiline opt text'' + let [text''', _ , _] = scanr ($) text' [ expandMultiline opt + , contextFilter (getFileLang opt filename) filt + ] -- parse source code, get the Cpp.Token list... - tokens = Cpp.tokenizer text''' + let tokens = Cpp.tokenizer text''' -- get matching tokens ... - tokens' = sortBy (compare `on` Cpp.toOffset) $ nub $ concatMap (\ms -> filterTokensWithMultiCards opt ms tokens) patterns'' + tokens' = sortBy (compare `on` Cpp.toOffset) $ nub $ concatMap (\ms -> filterTokensWithMultiCards opt ms tokens) patterns''' - matches = map (\t -> let n = fromIntegral (Cpp.toOffset t) in (n, Cpp.toString t)) tokens' :: [(Int, String)] + matches = map (\t -> let n = fromIntegral (Cpp.toOffset t) in (n, Cpp.toString t)) tokens' :: [(Int, String)] putStrLevel2 $ "tokens : " ++ show tokens' putStrLevel2 $ "matches : " ++ show matches diff --git a/src/CGrep/Strategy/Cpp/Tokenizer.hs b/src/CGrep/Strategy/Cpp/Tokenizer.hs --- a/src/CGrep/Strategy/Cpp/Tokenizer.hs +++ b/src/CGrep/Strategy/Cpp/Tokenizer.hs @@ -19,7 +19,7 @@ module CGrep.Strategy.Cpp.Tokenizer (search) where import qualified Data.ByteString.Char8 as C -import qualified CGrep.Semantic.Cpp.Token as Cpp +import qualified CGrep.Parser.Cpp.Token as Cpp import Control.Monad.Trans.Reader import Control.Monad.IO.Class @@ -40,33 +40,29 @@ search f ps = do opt <- ask + text <- liftIO $ getTargetContents f let filename = getTargetName f - text <- liftIO $ getTargetContents f - -- transform text - let text' = ignoreCase opt text - filt = (mkContextFilter opt) { getFilterComment = False } + let filt = (mkContextFilter opt) { getFilterComment = False } - putStrLevel1 $ "strategy : running C/C++ token search on " ++ filename ++ "..." + [text''', _ , text', _] = scanr ($) text [ expandMultiline opt + , contextFilter (getFileLang opt filename) filt + , ignoreCase opt + ] - --quickSearch ... - runSearch filename (quickSearch opt ps text') $ do - - -- context filter - - let text'' = contextFilter (getFileLang opt filename) filt text' + putStrLevel1 $ "strategy : running C/C++ token search on " ++ filename ++ "..." - -- expand multi-line + --quickSearch ... - text''' = expandMultiline opt text'' + runQuickSearch filename (quickSearch opt ps text') $ do -- parse source code, get the Cpp.Token list... - tokens = Cpp.tokenizer text''' + let tokens = Cpp.tokenizer text''' -- context-filterting... diff --git a/src/CGrep/Strategy/Generic/Semantic.hs b/src/CGrep/Strategy/Generic/Semantic.hs --- a/src/CGrep/Strategy/Generic/Semantic.hs +++ b/src/CGrep/Strategy/Generic/Semantic.hs @@ -19,15 +19,15 @@ module CGrep.Strategy.Generic.Semantic (search) where import qualified Data.ByteString.Char8 as C -import qualified CGrep.Semantic.Generic.Token as Generic +import qualified CGrep.Parser.Generic.Token as Generic import CGrep.Filter import CGrep.Lang import CGrep.Common import CGrep.Output -import CGrep.Semantic.Token -import CGrep.Semantic.WildCard +import CGrep.Parser.Token +import CGrep.Parser.WildCard import Control.Monad.Trans.Reader import Control.Monad.IO.Class @@ -45,11 +45,10 @@ search f ps = do opt <- ask + text <- liftIO $ getTargetContents f let filename = getTargetName f - text <- liftIO $ getTargetContents f - -- transform text let text' = ignoreCase opt text @@ -59,8 +58,8 @@ -- pre-process patterns patterns = map (Generic.tokenizer . contextFilter (getFileLang opt filename) filt) ps -- [ [t1,t2,..], [t1,t2...] ] - patterns' = map (map mkWildCardFromToken) patterns -- [ [w1,w2,..], [w1,w2,..] ] - patterns'' = map (combineMultiCard . map (:[])) patterns' -- [ [m1,m2,..], [m1,m2,..] ] == [[[w1], [w2],..], [[w1],[w2],..]] + patterns' = map (map mkWildCardFromToken) patterns -- [ [w1,w2,..], [w1,w2,..] ] + patterns'' = map (combineMultiCard . map (:[])) patterns' -- [ [m1,m2,..], [m1,m2,..] ] == [[[w1], [w2],..], [[w1],[w2],..]] -- quickSearch ... @@ -79,7 +78,7 @@ putStrLevel2 $ "identif : " ++ show ps' - runSearch filename (quickSearch opt (map C.pack ps') text') $ do + runQuickSearch filename (quickSearch opt (map C.pack ps') text') $ do -- context filter diff --git a/src/CGrep/Strategy/Levenshtein.hs b/src/CGrep/Strategy/Levenshtein.hs --- a/src/CGrep/Strategy/Levenshtein.hs +++ b/src/CGrep/Strategy/Levenshtein.hs @@ -35,34 +35,34 @@ search :: FilePath -> [Text8] -> ReaderT Options IO [Output] -search f ps = do +search f patterns = do opt <- ask + text <- liftIO $ getTargetContents f let filename = getTargetName f - text <- liftIO $ getTargetContents f - -- transform text - let text' = ignoreCase opt . contextFilter (getFileLang opt filename) (mkContextFilter opt) $ text - - text'' = expandMultiline opt text' + let [text''', _ , _ , _] = scanr ($) text [ expandMultiline opt + , contextFilter (getFileLang opt filename) (mkContextFilter opt) + , ignoreCase opt + ] -- parse source code, get the Cpp.Token list... - tokens' = tokenizer text'' + tokens' = tokenizer text''' -- filter tokens... - patterns = map C.unpack ps + patterns' = map C.unpack patterns - matches = filter (\t -> any (\p -> p ~== snd t) patterns) tokens' + matches = filter (\t -> any (\p -> p ~== snd t) patterns') tokens' putStrLevel1 $ "strategy : running edit-distance (Levenshtein) search on " ++ filename ++ "..." putStrLevel2 $ "tokens : " ++ show tokens' putStrLevel2 $ "matches : " ++ show matches - putStrLevel3 $ "---\n" ++ C.unpack text'' ++ "\n---" + putStrLevel3 $ "---\n" ++ C.unpack text''' ++ "\n---" - mkOutput filename text text'' matches + mkOutput filename text text''' matches diff --git a/src/CGrep/Strategy/Regex.hs b/src/CGrep/Strategy/Regex.hs --- a/src/CGrep/Strategy/Regex.hs +++ b/src/CGrep/Strategy/Regex.hs @@ -37,30 +37,24 @@ search :: FilePath -> [Text8] -> ReaderT Options IO [Output] -search f ps = do +search f patterns = do opt <- ask + text <- liftIO $ getTargetContents f let filename = getTargetName f - text <- liftIO $ getTargetContents f - -- transform text - let text' = expandMultiline opt . ignoreCase opt $ text - - -- context filter - - text'' = contextFilter (getFileLang opt filename) (mkContextFilter opt) text' - - -- expand multi-line - - text''' = expandMultiline opt text'' + let [text''', _ , _ , _] = scanr ($) text [ expandMultiline opt + , contextFilter (getFileLang opt filename) (mkContextFilter opt) + , ignoreCase opt + ] -- search for matching tokens tokens = map (\(str, (off,_)) -> (off, C.unpack str) ) $ - concatMap elems $ ps >>= (\p -> elems (getAllTextMatches $ text''' =~ p :: (Array Int) (MatchText Text8))) + concatMap elems $ patterns >>= (\p -> elems (getAllTextMatches $ text''' =~ p :: (Array Int) (MatchText Text8))) putStrLevel1 $ "strategy : running regex search on " ++ filename ++ "..." putStrLevel2 $ "tokens : " ++ show tokens diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -33,14 +33,14 @@ cgreprc = "cgreprc" version :: String -version = "6.5.6" +version = "6.5.8" data Config = Config - { configLanguages :: [Lang] - , configPruneDirs :: [String] - , configAutoColor :: Bool - } deriving (Show, Read) + { configLanguages :: [Lang] + , configPruneDirs :: [String] + , configAutoColor :: Bool + } deriving (Show, Read) @@ -52,8 +52,10 @@ getConfig :: IO Config getConfig = do home <- getHomeDirectory - confs <- filterM doesFileExist ["." ++ cgreprc, home "." ++ cgreprc, "/etc" cgreprc] - if notNull confs then liftM dropComments (readFile (head confs)) >>= \xs -> - return (prettyRead xs "Config error" :: Config) - else return $ Config [] [] False + confs <- filterM doesFileExist [cgreprc, "." ++ cgreprc, home "." ++ cgreprc, "/etc" cgreprc] + if notNull confs + then liftM dropComments (readFile (head confs)) >>= \xs -> + return (prettyRead xs "Config error" :: Config) + else return $ Config [] [] False + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -127,7 +127,7 @@ [] -> atomically $ writeTChan out_chan [] xs -> void ((if asynch opts then flip mapConcurrently else forM) xs $ \x -> do - out <- fmap (take (max_count opts)) (runReaderT (cgrepDispatch x patterns) (sanitizeOptions x opts)) + out <- fmap (take (max_count opts)) (runReaderT (runCgrep x patterns) (sanitizeOptions x opts)) unless (null out) $ atomically $ writeTChan out_chan out) ) (\e -> let msg = show (e :: SomeException) in hPutStrLn stderr (showFile opts (getTargetName (head fs)) ++ ": exception: " ++ if length msg > 80 then take 80 msg ++ "..." else msg))