skylighting-core-0.15: src/Skylighting/Tokenizer.hs
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Skylighting.Tokenizer (
tokenize
, TokenizerConfig(..)
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.UTF8 as UTF8
import Data.CaseInsensitive (mk)
import Data.Char (isAlphaNum, isAscii, isDigit, isLetter, isSpace, ord)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Debug.Trace
import Skylighting.Regex
import Skylighting.Types
import Data.List.NonEmpty (NonEmpty((:|)), (<|), toList)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
newtype Captures = Captures{ unCaptures :: IntMap.IntMap ByteString }
deriving (Show)
newtype ContextStack =
ContextStack{ unContextStack :: NonEmpty (Context, Captures) }
deriving (Show)
data TokenizerState = TokenizerState{
input :: ByteString
, endline :: Bool
, prevChar :: Char
, contextStack :: ContextStack
, captures :: Captures
, column :: Int
, lineContinuation :: Bool
, firstNonspaceColumn :: Maybe Int
, loopCounter :: Int
-- ^ number of consecutive rule-matching iterations without
-- consuming any input; used to guard against endless loops
}
-- | Configuration options for 'tokenize'.
data TokenizerConfig = TokenizerConfig{
syntaxMap :: SyntaxMap -- ^ Syntax map to use
, traceOutput :: Bool -- ^ Generate trace output for debugging
} deriving (Show)
data Result e a = Success a
| Failure
| Error e
deriving (Functor)
deriving instance (Show a, Show e) => Show (Result e a)
newtype TokenizerM a = TM { runTokenizerM :: TokenizerConfig
-> TokenizerState
-> (TokenizerState, Result String a) }
mapsnd :: (a -> b) -> (c, a) -> (c, b)
mapsnd f (x, y) = (x, f y)
instance Functor TokenizerM where
fmap f (TM g) = TM (\c s -> mapsnd (fmap f) (g c s))
instance Applicative TokenizerM where
pure x = TM (\_ s -> (s, Success x))
(TM f) <*> (TM y) = TM (\c s ->
case (f c s) of
(s', Failure ) -> (s', Failure)
(s', Error e ) -> (s', Error e)
(s', Success f') ->
case (y c s') of
(s'', Failure ) -> (s'', Failure)
(s'', Error e' ) -> (s'', Error e')
(s'', Success y') -> (s'', Success (f' y')))
instance Monad TokenizerM where
return = pure
(TM x) >>= f = TM (\c s ->
case x c s of
(s', Failure ) -> (s', Failure)
(s', Error e ) -> (s', Error e)
(s', Success x') -> g c s'
where TM g = f x')
instance Alternative TokenizerM where
empty = TM (\_ s -> (s, Failure))
(<|>) (TM x) (TM y) = TM (\c s ->
case x c s of
(_, Failure ) -> y c s
(s', Error e ) -> (s', Error e)
(s', Success x') -> (s', Success x'))
many (TM x) = TM (\c s ->
case x c s of
(_, Failure ) -> (s, Success [])
(s', Error e ) -> (s', Error e)
(s', Success x') -> mapsnd (fmap (x':)) (g c s')
where TM g = many (TM x))
some x = (:) <$> x <*> many x
instance MonadPlus TokenizerM where
mzero = empty
mplus = (<|>)
instance MonadReader TokenizerConfig TokenizerM where
ask = TM (\c s -> (s, Success c))
local f (TM x) = TM (x . f)
instance MonadState TokenizerState TokenizerM where
get = TM (\_ s -> (s, Success s))
put x = TM (\_ _ -> (x, Success ()))
instance MonadError String TokenizerM where
throwError e = TM (\_ s -> (s, Error e))
catchError (TM x) f = TM (\c s -> case x c s of
(_, Error e) -> let TM y = f e in y c s
z -> z)
-- | Tokenize some text using 'Syntax'.
-- Note that the syntax definitions are assumed to have their
-- keyword lists already resolved into word sets (as is the case
-- for the bundled syntax definitions and for definitions loaded
-- with the functions in Skylighting.Loader). If you construct a
-- syntax map yourself from syntaxes parsed with
-- 'Skylighting.Parser.parseSyntaxDefinition', apply
-- 'Skylighting.Parser.resolveKeywords' to each syntax first.
tokenize :: TokenizerConfig -> Syntax -> Text -> Either String [SourceLine]
tokenize config syntax inp =
eitherStack >>= \(!stack) ->
case runTokenizerM action config (startingState stack) of
(_, Success ls) -> Right ls
(_, Error e) -> Left e
(_, Failure) -> Left "Could not tokenize code"
where
action = mapM tokenizeLine (zip (BS.lines (encodeUtf8 inp)) [1..])
eitherStack = case lookupContext (sStartingContext syntax) syntax of
Just c -> Right $ ContextStack ((c, Captures mempty) :| [])
Nothing -> Left "No starting context specified"
startingState stack =
TokenizerState{ input = BS.empty
, endline = Text.null inp
, prevChar = '\n'
, contextStack = stack
, captures = Captures mempty
, column = 0
, lineContinuation = False
, firstNonspaceColumn = Nothing
, loopCounter = 0
}
info :: String -> TokenizerM ()
info s = do
tr <- asks traceOutput
when tr $ trace s (return ())
infoContextStack :: TokenizerM ()
infoContextStack = do
tr <- asks traceOutput
when tr $ do
ContextStack stack <- gets contextStack
info $ "CONTEXT STACK " ++ show (map (cName . fst) $ toList stack)
popContextStack :: TokenizerM ()
popContextStack = do
ContextStack cs <- gets contextStack
case cs of
(_ :| []) -> info "WARNING: Tried to pop only element on context stack!"
(_ :| (x:xs)) -> do
modify (\st -> st{ contextStack = ContextStack (x :| xs) })
infoContextStack
pushContextStack :: Context -> TokenizerM ()
pushContextStack cont = do
modify (\st -> st{ contextStack =
ContextStack
(((cont, Captures mempty) <|) . unContextStack
$ contextStack st) } )
infoContextStack
currentContext :: TokenizerM Context
currentContext = do
ContextStack ((c,_) :| _) <- gets contextStack
return c
doContextSwitch :: ContextSwitch -> TokenizerM ()
doContextSwitch Pop = popContextStack
doContextSwitch (Push (!syn,!c)) = do
syntaxes <- asks syntaxMap
case Map.lookup syn syntaxes >>= lookupContext c of
Just !con -> pushContextStack con
Nothing -> throwError $ "Unknown syntax or context: " ++ show (syn, c)
doContextSwitches :: [ContextSwitch] -> TokenizerM ()
doContextSwitches = mapM_ doContextSwitch
addCaptures :: TokenizerM ()
addCaptures = do
capts <- gets captures
if IntMap.null (unCaptures capts)
then return ()
else do
ContextStack ((c,_) :| cs) <- gets contextStack
info $ "Adding captures to " <> show (cName c) <> ": " <> show capts
modify $ \st -> st{ contextStack = ContextStack ((c,capts) :| cs) }
getCapture :: Int -> TokenizerM Text
getCapture capnum = do
ContextStack ((_,Captures capts) :| _) <- gets contextStack
info $ "Retrieving capture " <> show capnum
res <- case IntMap.lookup capnum capts of
Nothing -> do
info "Not found"
mzero
Just x -> decodeBS x
info $ "Got " <> show res
return res
lookupContext :: Text -> Syntax -> Maybe Context
lookupContext name syntax | Text.null name =
if Text.null (sStartingContext syntax)
then Nothing
else lookupContext (sStartingContext syntax) syntax
lookupContext name syntax = Map.lookup name $ sContexts syntax
tokenizeLine :: (ByteString, Int) -> TokenizerM [Token]
tokenizeLine (!ln, !linenum) = do
-- column and firstNonspaceColumn restart on every physical line;
-- a line continuation only suppresses the previous line's
-- lineEndContext (KDE abstracthighlighter.cpp, highlightLine).
let !mbFirstNonspace = BS.findIndex (not . isSpace) $! ln
modify $ \st -> st{ input = ln
, endline = BS.null ln
, prevChar = '\n'
, lineContinuation = False
, column = 0
, firstNonspaceColumn = mbFirstNonspace
, loopCounter = 0 }
if BS.null ln
then do
-- Empty lines get only the lineEmptyContext switches (which
-- default to the lineEndContext switches), applied for
-- successive top contexts until #stay; the lineEndContext is
-- not applied separately (KDE abstracthighlighter.cpp).
handleEmptyLine loopLimit
return []
else do
ts <- normalizeHighlighting . catMaybes <$> many getToken
eol <- gets endline
if eol
then do
checkLineEnd
return ts
else do -- fail if we haven't consumed whole line
col <- gets column
throwError $ "Could not match anything at line " ++
show linenum ++ " column " ++ show col
-- | Limit on iterations that make no progress, to avoid endless
-- loops with broken syntax definitions, as in KDE's
-- abstracthighlighter.cpp.
loopLimit :: Int
loopLimit = 1024
-- | Apply line-empty context switches for successive top contexts
-- until a context with no switches (#stay) is on top, guarding
-- against endless loops (KDE abstracthighlighter.cpp, highlightLine).
handleEmptyLine :: Int -> TokenizerM ()
handleEmptyLine counter = do
cur <- currentContext
case cLineEmptyContext cur of
[] -> return () -- #stay
switches
| counter <= 0 -> info $ "Endless switch context transitions " ++
"for line empty context, aborting highlighting of line."
| otherwise -> do
before <- gets (fmap fst . unContextStack . contextStack)
doContextSwitches switches
after <- gets (fmap fst . unContextStack . contextStack)
-- if the stack is unchanged (e.g. #pop of the initial
-- context), stop:
when (before /= after) $ handleEmptyLine (counter - 1)
getToken :: TokenizerM (Maybe Token)
getToken = do
inp <- gets input
gets endline >>= guard . not
!context <- currentContext
counter <- gets loopCounter
if counter > loopLimit
-- too many iterations without consuming input (e.g. a cycle of
-- context switches): abort highlighting of this line, giving
-- the rest of it the context's attribute, as in KDE's
-- abstracthighlighter.cpp.
then do
info "Endless state transitions, aborting highlighting of line."
t <- decodeBS inp
modify $ \st -> st{ input = BS.empty
, endline = True
, prevChar = Text.last t
, column = column st + Text.length t }
return $ Just (cAttribute context, t)
else getToken' context inp counter
getToken' :: Context -> ByteString -> Int -> TokenizerM (Maybe Token)
getToken' context inp counter = do
modify $ \st -> st{ loopCounter = counter + 1 }
msum (map (\r -> tryRule r inp) (cRules context)) <|>
case cFallthroughContext context of
[] | cFallthrough context -> Nothing <$ doContextSwitches [Pop]
| otherwise -> do
t <- normalChunk
let mbtok = Just (cAttribute context, t)
info $ "FALLTHROUGH " ++ show mbtok
return mbtok
cs -> Nothing <$ doContextSwitches cs
takeChars :: Int -> TokenizerM Text
takeChars 0 = mzero
takeChars numchars = do
inp <- gets input
let (bs,rest) = UTF8.splitAt numchars inp
guard $ not (BS.null bs)
!t <- decodeBS bs
modify $ \st -> st{ input = rest,
endline = BS.null rest,
prevChar = Text.last t,
column = column st + numchars,
loopCounter = 0 } -- input was consumed: progress
return t
tryRule :: Rule -> ByteString -> TokenizerM (Maybe Token)
tryRule _ "" = mzero
tryRule rule inp = do
info $ "Trying rule " ++ show rule
case rColumn rule of
Nothing -> return ()
Just n -> gets column >>= guard . (== n)
when (rFirstNonspace rule) $ do
!firstNonspace <- gets firstNonspaceColumn
!col <- gets column
guard (firstNonspace == Just col)
oldstate <- if rLookahead rule
then Just <$> get -- needed for lookahead rules
else return Nothing
-- reset regex captures
modify $ \st -> st{ captures = Captures mempty }
let attr = rAttribute rule
let delims = rWordDelimiters rule
mbtok <- case rMatcher rule of
DetectChar c -> withAttr attr $ detectChar (rDynamic rule) c inp
Detect2Chars c d -> withAttr attr $
detect2Chars (rDynamic rule) c d inp
AnyChar cs -> withAttr attr $ anyChar cs inp
RangeDetect c d -> withAttr attr $ rangeDetect c d inp
RegExpr re -> withAttr attr $ regExpr (rDynamic rule) re inp
Int -> withAttr attr $ parseInt delims inp
HlCOct -> withAttr attr $ parseOct delims inp
HlCHex -> withAttr attr $ parseHex delims inp
HlCStringChar -> withAttr attr $ parseCStringChar inp
HlCChar -> withAttr attr $ parseCChar inp
Float -> withAttr attr $ parseFloat delims inp
Keyword _kwattr (Left listname) ->
throwError $ "Keyword with unresolved list " <> show listname
Keyword kwattr (Right kws) ->
withAttr attr $ keyword kwattr kws inp
StringDetect s -> withAttr attr $
stringDetect (rDynamic rule) (rCaseSensitive rule)
s inp
WordDetect s -> withAttr attr $
wordDetect (rCaseSensitive rule)
delims s inp
LineContinue c -> withAttr attr $ lineContinue c inp
DetectSpaces -> withAttr attr $ detectSpaces inp
DetectIdentifier -> withAttr attr $ detectIdentifier inp
IncludeRules cname -> includeRules
(if rIncludeAttribute rule then Just attr else Nothing)
cname inp
mbchildren <- do
inp' <- gets input
msum (map (\r -> tryRule r inp') (rChildren rule)) <|> return Nothing
mbtok' <- case mbtok of
Nothing -> return Nothing
Just (tt, s)
| rLookahead rule -> do
(oldinput, oldendline, oldprevChar, oldColumn,
oldLoopCounter) <-
case oldstate of
Nothing -> throwError
"oldstate not saved with lookahead rule"
Just st -> return
(input st, endline st,
prevChar st, column st,
loopCounter st)
-- restore loopCounter too: a lookahead match makes
-- no progress, so it must not reset the
-- endless-loop guard (takeChars reset it):
modify $ \st -> st{ input = oldinput
, endline = oldendline
, prevChar = oldprevChar
, column = oldColumn
, loopCounter = oldLoopCounter }
return Nothing
| otherwise -> do
case mbchildren of
Nothing -> return $ Just (tt, s)
Just (_, cresult) -> return $ Just (tt, s <> cresult)
info $ takeWhile (/=' ') (show (rMatcher rule)) ++ " MATCHED " ++ show mbtok'
doContextSwitches (rContextSwitch rule)
-- Add any captures to the context on top of the stack
addCaptures
return mbtok'
withAttr :: TokenType -> TokenizerM Text -> TokenizerM (Maybe Token)
withAttr tt p = do
res <- p
if Text.null res
then return Nothing
else return $ Just (tt, res)
wordDetect :: Bool -> Set.Set Char -> Text -> ByteString
-> TokenizerM Text
wordDetect caseSensitive delims s inp = do
t <- if caseSensitive
then do -- fast path: compare bytes without decoding
guard $ encodeUtf8 s `BS.isPrefixOf` inp
return s
else do
t <- decodeBS $ UTF8.take (Text.length s) inp
-- we assume here that the case fold will not change length,
-- which is safe for ASCII keywords and the like...
guard $ mk s == mk t
return t
guard $ not (Text.null t)
let isDelim = (`Set.member` delims)
-- KDE requires a word delimiter (or start of line) before the
-- word, or as its first character (this is why \n<DOCTYPE!
-- matches \b<DOCTYPE!/b):
prev <- gets prevChar
guard $ isDelim prev || isDelim (Text.head t)
let c = Text.last t
let rest = UTF8.drop (Text.length s) inp
let d = case UTF8.uncons rest of
Nothing -> '\n'
Just (x,_) -> x
-- ... and a word delimiter (or end of line) after the word, or
-- as its last character:
guard $ isDelim d || isDelim c
takeChars (Text.length t)
stringDetect :: Bool -> Bool -> Text -> ByteString -> TokenizerM Text
stringDetect dynamic caseSensitive s inp = do
s' <- if dynamic
then do
dynStr <- subDynamicText s
info $ "Dynamic string: " ++ show dynStr
return dynStr
else return s
if caseSensitive
then -- fast path: compare bytes without decoding
guard $ encodeUtf8 s' `BS.isPrefixOf` inp
else do
t <- decodeBS $ UTF8.take (Text.length s') inp
-- we assume here that the case fold will not change length,
-- which is safe for ASCII keywords and the like...
guard $ mk s' == mk t
takeChars (Text.length s')
subDynamicText :: Text -> TokenizerM Text
subDynamicText t = do
let substitute x = case Text.uncons x of
Just (c, rest) | isDigit c -> let capNum = ord c - ord '0'
in (<> rest) <$> getCapture capNum
_ -> return $ Text.cons '%' x
case Text.split (== '%') t of
[] -> return Text.empty
x:rest -> (x <>) . Text.concat <$> mapM substitute rest
-- This assumes that nothing significant will happen
-- in the middle of a string of spaces or a string
-- of alphanumerics. This seems true for all normal
-- programming languages, and the optimization speeds
-- things up a lot, relative to just parsing one char.
normalChunk :: TokenizerM Text
normalChunk = do
inp <- gets input
case UTF8.uncons inp of
Nothing -> mzero
Just (c, _)
| c == ' ' ->
let bs = BS.takeWhile (==' ') inp
in takeChars (BS.length bs)
| isAscii c && isAlphaNum c ->
let (bs, _) = UTF8.span isAlphaNum inp
in takeChars (UTF8.length bs)
| otherwise -> takeChars 1
includeRules :: Maybe TokenType -> ContextName -> ByteString
-> TokenizerM (Maybe Token)
includeRules mbattr (syn, con) inp = do
syntaxes <- asks syntaxMap
case Map.lookup syn syntaxes >>= lookupContext con of
Nothing -> do
cur <- currentContext
throwError $ "IncludeRules in " ++ Text.unpack (cSyntax cur) ++
" requires undefined context " ++
Text.unpack con ++ "##" ++ Text.unpack syn
Just c -> do
mbtok <- msum (map (\r -> tryRule r inp) (cRules c))
modify $ \st -> st{ captures = Captures mempty }
return $ case (mbtok, mbattr) of
(Just (NormalTok, xs), Just attr) -> Just (attr, xs)
_ -> mbtok
-- | Apply line-end context switches for successive top contexts
-- until a context with no switches (#stay) is on top, guarding
-- against endless loops (KDE abstracthighlighter.cpp, highlightLine).
checkLineEnd :: TokenizerM ()
checkLineEnd = do
lineCont' <- gets lineContinuation
unless lineCont' $ go loopLimit
where
go counter = do
c <- currentContext
unless (null (cLineEndContext c)) $
if counter <= 0
then info $ "Endless switch context transitions " ++
"for line end context, aborting highlighting of line."
else do
info $ "checkLineEnd for " ++ show (cName c) ++
" cLineEndContext = " ++ show (cLineEndContext c)
before <- gets (fmap fst . unContextStack . contextStack)
doContextSwitches (cLineEndContext c)
after <- gets (fmap fst . unContextStack . contextStack)
-- if the stack is unchanged (e.g. #pop of the initial
-- context), stop:
when (before /= after) $ go (counter - 1)
detectChar :: Bool -> Char -> ByteString -> TokenizerM Text
detectChar dynamic c inp = do
c' <- if dynamic && c >= '0' && c <= '9'
then getDynamicChar c
else return c
case UTF8.uncons inp of
Just (x,_) | x == c' -> takeChars 1
_ -> mzero
getDynamicChar :: Char -> TokenizerM Char
getDynamicChar c = do
let capNum = ord c - ord '0'
res <- getCapture capNum
case Text.uncons res of
Nothing -> mzero
Just (d,_) -> return d
detect2Chars :: Bool -> Char -> Char -> ByteString -> TokenizerM Text
detect2Chars dynamic c d inp = do
c' <- if dynamic && c >= '0' && c <= '9'
then getDynamicChar c
else return c
d' <- if dynamic && d >= '0' && d <= '9'
then getDynamicChar d
else return d
case UTF8.uncons inp of
Just (x, rest) | x == c' ->
case UTF8.uncons rest of
Just (y, _) | y == d' -> takeChars 2
_ -> mzero
_ -> mzero
rangeDetect :: Char -> Char -> ByteString -> TokenizerM Text
rangeDetect c d inp = do
case UTF8.uncons inp of
Just (x, rest)
| x == c -> case UTF8.span (/= d) rest of
(in_t, out_t)
| BS.null out_t -> mzero
| otherwise -> do
t <- decodeBS in_t
takeChars (Text.length t + 2)
_ -> mzero
-- NOTE: currently limited to ASCII
detectSpaces :: ByteString -> TokenizerM Text
detectSpaces inp = do
case BS.span (\c -> isSpace c) inp of
(t, _)
| BS.null t -> mzero
| otherwise -> takeChars (BS.length t)
-- NOTE: limited to ASCII as per kate documentation
detectIdentifier :: ByteString -> TokenizerM Text
detectIdentifier inp = do
case BS.uncons inp of
Just (c, t) | (isAscii c && isLetter c) || c == '_' ->
takeChars $ 1 + maybe (BS.length t) id
(BS.findIndex (\d -> not (isAscii d) ||
not (isAlphaNum d || d == '_')) t)
_ -> mzero
lineContinue :: Char -> ByteString -> TokenizerM Text
lineContinue c inp = do
if inp == UTF8.fromString [c]
then do
modify $ \st -> st{ lineContinuation = True }
takeChars 1
else mzero
anyChar :: Set.Set Char -> ByteString -> TokenizerM Text
anyChar cs inp = do
case UTF8.uncons inp of
Just (x, _) | x `Set.member` cs -> takeChars 1
_ -> mzero
regExpr :: Bool -> RE -> ByteString -> TokenizerM Text
regExpr dynamic re inp = do
-- return $! traceShowId $! (reStr, inp)
let reStr = reString re
when (BS.take 2 reStr == "\\b") $ wordBoundary inp
(regex, groups) <- case compileRE re of
Right r -> return r
Left e -> throwError $
"Error compiling regex " ++
UTF8.toString reStr ++ ": " ++ e
mbmatch <- if dynamic
then do
regex' <- subDynamic regex
-- the capturing groups have to be recomputed after
-- dynamic substitution (matchRegex does this):
return $ matchRegex regex' inp
else return $ matchRegexWithGroups groups regex inp
case mbmatch of
Just (matchedBytes, capts) -> do
unless (null capts) $
modify $ \st -> st{ captures = Captures $
IntMap.map (toSlice inp) capts }
takeChars (UTF8.length matchedBytes)
_ -> mzero
toSlice :: ByteString -> (Int, Int) -> ByteString
toSlice bs (off, len) = BS.take len $ BS.drop off bs
wordBoundary :: ByteString -> TokenizerM ()
wordBoundary inp = do
case UTF8.uncons inp of
Nothing -> return ()
Just (d, _) -> do
c <- gets prevChar
guard $ isWordBoundary c d
isWordBoundary :: Char -> Char -> Bool
isWordBoundary c d = isWordChar c /= isWordChar d
-- In KDE, Int, Float, HlCOct, and HlCHex rules match only if the
-- preceding character is a word delimiter (or we are at the start
-- of the line, which we detect via prevChar == '\n', since '\n'
-- is always a delimiter). Nothing is required of the character
-- following the match.
precededByWordDelim :: Set.Set Char -> TokenizerM ()
precededByWordDelim delims = do
c <- gets prevChar
guard $ c `Set.member` delims
decodeBS :: ByteString -> TokenizerM Text
decodeBS bs = case decodeUtf8' bs of
Left _ -> throwError ("ByteString " ++
show bs ++ "is not UTF8")
Right t -> return t
-- Substitute out %1, %2, etc. in regex string, escaping
-- appropriately..
subDynamic :: Regex -> TokenizerM Regex
subDynamic (MatchDynamic capNum) = do
replacement <- getCapture capNum
return $ mconcat $ map (MatchChar . (==)) $ Text.unpack replacement
subDynamic (MatchAlt r1 r2) =
MatchAlt <$> subDynamic r1 <*> subDynamic r2
subDynamic (MatchConcat r1 r2) =
MatchConcat <$> subDynamic r1 <*> subDynamic r2
subDynamic (MatchSome r) =
MatchSome <$> subDynamic r
subDynamic (MatchCapture i r) =
MatchCapture i <$> subDynamic r
subDynamic (AssertPositive dir r) =
AssertPositive dir <$> subDynamic r
subDynamic (AssertNegative dir r) =
AssertNegative dir <$> subDynamic r
subDynamic x = return x
keyword :: KeywordAttr -> WordSet Text -> ByteString -> TokenizerM Text
keyword kwattr kws inp = do
prev <- gets prevChar
guard $ prev `Set.member` (keywordDelims kwattr)
let (w,_) = UTF8.break (`Set.member` (keywordDelims kwattr)) inp
guard $ not (BS.null w)
w' <- decodeBS w
let numchars = Text.length w'
if w' `inWordSet` kws
then takeChars numchars
else mzero
normalizeHighlighting :: [Token] -> [Token]
normalizeHighlighting [] = []
normalizeHighlighting ((!t,!x):xs)
| Text.null x = normalizeHighlighting xs
| otherwise =
(t, matchedText) : normalizeHighlighting rest
where (matches, rest) = span (\(z,_) -> z == t) xs
!matchedText = Text.concat (x : map snd matches)
parseCStringChar :: ByteString -> TokenizerM Text
parseCStringChar inp = do
case A.parseOnly (A.match pCStringChar) inp of
Left _ -> mzero
Right (r,_) -> takeChars (BS.length r) -- assumes ascii
pCStringChar :: A.Parser ()
pCStringChar = do
_ <- A.char '\\'
next <- A.anyChar
case next of
c | c == 'x' || c == 'X' -> () <$ A.takeWhile1 (A.inClass "0-9a-fA-F")
| c == '0' -> () <$ A.takeWhile (A.inClass "0-7")
| A.inClass "abefnrtv\"'?\\" c -> return ()
| otherwise -> mzero
parseCChar :: ByteString -> TokenizerM Text
parseCChar inp = do
case A.parseOnly (A.match pCChar) inp of
Left _ -> mzero
Right (r,_) -> takeChars (BS.length r) -- assumes ascii
pCChar :: A.Parser ()
pCChar = do
() <$ A.char '\''
pCStringChar <|> () <$ A.satisfy (\c -> c /= '\'' && c /= '\\')
() <$ A.char '\''
-- Like KDE's Int rule: a sequence of one or more decimal digits.
-- No sign, and no hex or octal forms.
parseInt :: Set.Set Char -> ByteString -> TokenizerM Text
parseInt delims inp = do
precededByWordDelim delims
case A.parseOnly (A.match (void $ A.takeWhile1 (A.inClass "0-9"))) inp of
Left _ -> mzero
Right (r,_) -> takeChars (BS.length r) -- assumes ascii
-- Like KDE's HlCOct rule: a C-style octal, 0 followed by one or
-- more octal digits. No sign, and no "0o" prefix.
parseOct :: Set.Set Char -> ByteString -> TokenizerM Text
parseOct delims inp = do
precededByWordDelim delims
case A.parseOnly (A.match pOct) inp of
Left _ -> mzero
Right (r,_) -> takeChars (BS.length r) -- assumes ascii
pOct :: A.Parser ()
pOct = do
_ <- A.char '0'
_ <- A.takeWhile1 (A.inClass "0-7")
return ()
-- Like KDE's HlCHex rule: 0x or 0X followed by one or more hex
-- digits. No sign.
parseHex :: Set.Set Char -> ByteString -> TokenizerM Text
parseHex delims inp = do
precededByWordDelim delims
case A.parseOnly (A.match pHex) inp of
Left _ -> mzero
Right (r,_) -> takeChars (BS.length r) -- assumes ascii
pHex :: A.Parser ()
pHex = do
_ <- A.char '0'
_ <- A.satisfy (A.inClass "Xx")
_ <- A.takeWhile1 (A.inClass "0-9a-fA-F")
return ()
-- Like KDE's Float rule: optional digits, a mandatory '.', and
-- optional digits (at least one digit is required on one side of
-- the dot), followed by an optional exponent (e or E, an optional
-- sign, and digits); if the exponent is not complete, the match
-- ends before the e/E. No leading sign, and "5e2" is not a Float.
parseFloat :: Set.Set Char -> ByteString -> TokenizerM Text
parseFloat delims inp = do
precededByWordDelim delims
case A.parseOnly (A.match pFloat) inp of
Left _ -> mzero
Right (r,_) -> takeChars (BS.length r) -- assumes all ascii
where pFloat :: A.Parser ()
pFloat = do
before <- A.takeWhile (A.inClass "0-9")
_ <- A.char '.'
after <- A.takeWhile (A.inClass "0-9")
guard $ not (BS.null before && BS.null after)
A.option () $ do
_ <- A.satisfy (A.inClass "Ee")
_ <- A.option '+' (A.satisfy (A.inClass "+-"))
void $ A.takeWhile1 (A.inClass "0-9")