diff --git a/benchmark/benchmark.hs b/benchmark/benchmark.hs new file mode 100644 --- /dev/null +++ b/benchmark/benchmark.hs @@ -0,0 +1,33 @@ +import Skylighting +import Criterion.Main +import Criterion.Types (Config(..)) +import System.FilePath +import System.Directory +import Data.Text (Text) +import qualified Data.Text as Text + +main :: IO () +main = do + -- inputs <- filter (\fp -> take 1 fp /= ".") + -- <$> getDirectoryContents ("test" "cases") + let inputs = ["abc.haskell", "abc.java", "abc.c", "archive.rhtml", + "life.lua", "abc.javascript"] + let getCase fp = do + let fp' = "test" "cases" fp + contents <- readFile fp' + let format = drop 1 $ takeExtension fp + return (Text.pack format, Text.pack contents) + cases <- mapM getCase inputs + defaultMainWith defaultConfig{ timeLimit = 10.0 } + $ map testBench cases + +testBench :: (Text, Text) -> Benchmark +testBench (format, contents) = + bench (Text.unpack format) $ nf + (sum . map length . either (error "tokenize failed") id . + tokenize TokenizerConfig{ traceOutput = False + , syntaxMap = defaultSyntaxMap } syntax) contents + + where syntax = maybe (error "could not find syntax") id + (lookupSyntax format defaultSyntaxMap) + diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -14,3 +14,9 @@ * Fixed performance bug in regex application (#1). This gives a significant speedup, especially for inputs with long lines. +## 0.1.1.1 -- 2017-01-21 + +* Optimized. Speed is now comparable to highlighting-kate + and often better. +* Added benchmarks. + diff --git a/skylighting.cabal b/skylighting.cabal --- a/skylighting.cabal +++ b/skylighting.cabal @@ -1,5 +1,5 @@ name: skylighting -version: 0.1.1 +version: 0.1.1.1 synopsis: syntax highlighting library description: Skylighting is a syntax highlighting library with support for over one hundred languages. It derives @@ -333,4 +333,20 @@ ghc-options: -Wall if flag(bootstrap) buildable: False + +benchmark benchmark-skylighting + Type: exitcode-stdio-1.0 + Main-Is: benchmark.hs + Hs-Source-Dirs: benchmark + if impl(ghc < 7.10) + Hs-Source-Dirs: prelude + Other-Modules: Prelude + Build-Depends: skylighting, + base >= 4.2 && < 5, + filepath, + text, + directory, + criterion >= 1.0 && < 1.2 + Ghc-Options: -rtsopts -Wall -fno-warn-unused-do-bind + Default-Language: Haskell2010 diff --git a/src/Skylighting/Tokenizer.hs b/src/Skylighting/Tokenizer.hs --- a/src/Skylighting/Tokenizer.hs +++ b/src/Skylighting/Tokenizer.hs @@ -7,10 +7,11 @@ import Control.Applicative import Control.Monad.Except import Control.Monad.Reader -import Control.Monad.State +import Control.Monad.State.Strict import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Char8 (ByteString) import Data.CaseInsensitive (mk) -import Data.Char (isAlphaNum, isLetter, isSpace, ord) +import Data.Char (isAlphaNum, isAscii, isLetter, isSpace, ord) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid @@ -18,6 +19,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import qualified Data.ByteString.UTF8 as UTF8 import Debug.Trace import Skylighting.Regex import Skylighting.Types @@ -38,10 +40,10 @@ deriving (Show) data TokenizerState = TokenizerState{ - input :: Text + input :: ByteString , prevChar :: Char , contextStack :: ContextStack - , captures :: [Text] + , captures :: [ByteString] , column :: Int , lineContinuation :: Bool , firstNonspaceColumn :: Maybe Int @@ -106,8 +108,9 @@ tokenize config syntax inp = evalState (runReaderT - (runExceptT (mapM tokenizeLine $ zip (Text.lines inp) [1..])) config) - startingState{ input = inp + (runExceptT (mapM tokenizeLine $ + zip (BS.lines $ encodeUtf8 inp) [1..])) config) + startingState{ input = encodeUtf8 inp , contextStack = case lookupContext (sStartingContext syntax) syntax of Just c -> ContextStack [c] @@ -115,7 +118,7 @@ startingState :: TokenizerState startingState = - TokenizerState{ input = Text.empty + TokenizerState{ input = BS.empty , prevChar = '\n' , contextStack = ContextStack [] , captures = [] @@ -124,7 +127,7 @@ , firstNonspaceColumn = Nothing } -tokenizeLine :: (Text, Int) -> TokenizerM [Token] +tokenizeLine :: (ByteString, Int) -> TokenizerM [Token] tokenizeLine (ln, linenum) = do cur <- currentContext lineCont <- gets lineContinuation @@ -133,29 +136,29 @@ else do modify $ \st -> st{ column = 0 , firstNonspaceColumn = - Text.findIndex (not . isSpace) ln } + BS.findIndex (not . isSpace) ln } doContextSwitch (cLineBeginContext cur) - if Text.null ln + if BS.null ln then doContextSwitch (cLineEmptyContext cur) else doContextSwitch (cLineBeginContext cur) modify $ \st -> st{ input = ln, prevChar = '\n' } ts <- normalizeHighlighting . catMaybes <$> many getToken - currentContext >>= checkLineEnd - -- fail if we haven't consumed whole line inp <- gets input - if not (Text.null inp) + if BS.null inp then do + currentContext >>= 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 - else return ts getToken :: TokenizerM (Maybe Token) getToken = do inp <- gets input - guard $ not (Text.null inp) + guard $ not (BS.null inp) context <- currentContext - msum (map tryRule (cRules context)) <|> + msum (map (\r -> tryRule r inp) (cRules context)) <|> if cFallthrough context then doContextSwitch (cFallthroughContext context) >> getToken else (\x -> Just (cAttribute context, x)) <$> normalChunk @@ -164,65 +167,74 @@ takeChars 0 = mzero takeChars numchars = do inp <- gets input - let t = Text.take numchars inp - let rest = Text.drop numchars inp + let (bs,rest) = UTF8.splitAt numchars inp + guard $ not (BS.null bs) + t <- decodeBS bs modify $ \st -> st{ input = rest, prevChar = Text.last t, column = column st + numchars } return t -tryRule :: Rule -> TokenizerM (Maybe Token) -tryRule rule = do +tryRule :: Rule -> ByteString -> TokenizerM (Maybe Token) +tryRule _ "" = mzero +tryRule rule inp = do case rColumn rule of Nothing -> return () - Just n -> do - col <- gets column - guard (col == n) + Just n -> gets column >>= guard . (== n) when (rFirstNonspace rule) $ do firstNonspace <- gets firstNonspaceColumn col <- gets column guard (firstNonspace == Just col) - oldstate <- get -- needed for lookahead rules + oldstate <- if rLookahead rule + then Just <$> get -- needed for lookahead rules + else return Nothing let attr = rAttribute rule mbtok <- case rMatcher rule of - DetectChar c -> withAttr attr $ detectChar (rDynamic rule) c + DetectChar c -> withAttr attr $ detectChar (rDynamic rule) c inp Detect2Chars c d -> withAttr attr $ - detect2Chars (rDynamic rule) c d - AnyChar cs -> withAttr attr $ anyChar cs - RangeDetect c d -> withAttr attr $ rangeDetect c d - RegExpr re -> withAttr attr $ regExpr (rDynamic rule) re - Int -> withAttr attr $ regExpr False integerRegex - HlCOct -> withAttr attr $ regExpr False octRegex - HlCHex -> withAttr attr $ regExpr False hexRegex + 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 $ regExpr False integerRegex inp + HlCOct -> withAttr attr $ regExpr False octRegex inp + HlCHex -> withAttr attr $ regExpr False hexRegex inp HlCStringChar -> withAttr attr $ - regExpr False hlCStringCharRegex - HlCChar -> withAttr attr $ regExpr False hlCCharRegex - Float -> withAttr attr $ regExpr False floatRegex + regExpr False hlCStringCharRegex inp + HlCChar -> withAttr attr $ regExpr False hlCCharRegex inp + Float -> withAttr attr $ regExpr False floatRegex inp Keyword kwattr kws -> - withAttr attr $ keyword kwattr kws + withAttr attr $ keyword kwattr kws inp StringDetect s -> withAttr attr $ - stringDetect (rCaseSensitive rule) s + stringDetect (rCaseSensitive rule) s inp WordDetect s -> withAttr attr $ - wordDetect (rCaseSensitive rule) s - LineContinue -> withAttr attr $ lineContinue - DetectSpaces -> withAttr attr $ detectSpaces - DetectIdentifier -> withAttr attr $ detectIdentifier + wordDetect (rCaseSensitive rule) s inp + LineContinue -> withAttr attr $ lineContinue inp + DetectSpaces -> withAttr attr $ detectSpaces inp + DetectIdentifier -> withAttr attr $ detectIdentifier inp IncludeRules cname -> includeRules (if rIncludeAttribute rule then Just attr else Nothing) - cname - mbchildren <- msum (map tryRule (rChildren rule)) - <|> return 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 - modify $ \st -> st{ input = input oldstate - , prevChar = prevChar oldstate - , column = column oldstate } + (oldinput, oldprevChar, oldColumn) <- + case oldstate of + Nothing -> throwError + "oldstate not saved with lookahead rule" + Just st -> return + (input st, prevChar st, column st) + modify $ \st -> st{ input = oldinput + , prevChar = oldprevChar + , column = oldColumn } return Nothing | otherwise -> do case mbchildren of @@ -236,9 +248,9 @@ withAttr :: TokenType -> TokenizerM Text -> TokenizerM (Maybe Token) withAttr tt p = do res <- p - case res of - "" -> return Nothing - xs -> return $ Just (tt, xs) + if Text.null res + then return Nothing + else return $ Just (tt, res) hlCStringCharRegex :: RE hlCStringCharRegex = RE{ @@ -247,7 +259,7 @@ , reCaseSensitive = False } -reHlCStringChar :: BS.ByteString +reHlCStringChar :: ByteString reHlCStringChar = "\\\\(?:[abefnrtv\"'?\\\\]|[xX][a-fA-F0-9]+|0[0-7]+)" hlCCharRegex :: RE @@ -258,27 +270,24 @@ } where reStr = "'(?:" <> reHlCStringChar <> "|[^'\\\\])'" -wordDetect :: Bool -> Text -> TokenizerM Text -wordDetect caseSensitive s = do - res <- stringDetect caseSensitive s +wordDetect :: Bool -> Text -> ByteString -> TokenizerM Text +wordDetect caseSensitive s inp = do + res <- stringDetect caseSensitive s inp -- now check for word boundary: (TODO: check to make sure this is correct) - inp <- gets input - case Text.uncons inp of + case UTF8.uncons inp of Just (c, _) | not (isAlphaNum c) -> return res - _ -> mzero + _ -> mzero -stringDetect :: Bool -> Text -> TokenizerM Text -stringDetect caseSensitive s = do - inp <- gets input - let len = Text.length s - let t = Text.take len inp +stringDetect :: Bool -> Text -> ByteString -> TokenizerM Text +stringDetect caseSensitive s inp = 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... let matches = if caseSensitive then s == t else mk s == mk t if matches - then takeChars len + then takeChars (Text.length s) else mzero -- This assumes that nothing significant will happen @@ -289,22 +298,25 @@ normalChunk :: TokenizerM Text normalChunk = do inp <- gets input - case Text.uncons inp of + case BS.uncons inp of Nothing -> mzero - Just (c, t) + Just (c, _) | c == ' ' -> - takeChars $ 1 + maybe 0 id (Text.findIndex (/=' ') t) - | isAlphaNum c -> - takeChars $ 1 + maybe 0 id (Text.findIndex (not . isAlphaNum) t) + let (bs,_) = BS.span (==' ') inp + in takeChars (BS.length bs) + | isAscii c && isAlphaNum c -> + let (bs,_) = BS.span isAlphaNum inp + in takeChars (BS.length bs) | otherwise -> takeChars 1 -includeRules :: Maybe TokenType -> ContextName -> TokenizerM (Maybe Token) -includeRules mbattr (syn, con) = do +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 -> throwError $ "Context lookup failed " ++ show (syn, con) Just c -> do - mbtok <- msum (map tryRule (cRules c)) + mbtok <- msum (map (\r -> tryRule r inp) (cRules c)) checkLineEnd c return $ case (mbtok, mbattr) of (Just (NormalTok, xs), Just attr) -> @@ -314,17 +326,16 @@ checkLineEnd :: Context -> TokenizerM () checkLineEnd c = do inp <- gets input - when (Text.null inp) $ do + when (BS.null inp) $ do lineCont' <- gets lineContinuation unless lineCont' $ doContextSwitch (cLineEndContext c) -detectChar :: Bool -> Char -> TokenizerM Text -detectChar dynamic c = do +detectChar :: Bool -> Char -> ByteString -> TokenizerM Text +detectChar dynamic c inp = do c' <- if dynamic && c >= '0' && c <= '9' then getDynamicChar c else return c - inp <- gets input - case Text.uncons inp of + case UTF8.uncons inp of Just (x,_) | x == c' -> takeChars 1 _ -> mzero @@ -336,92 +347,88 @@ Nothing -> mzero Just (d,_) -> return d -detect2Chars :: Bool -> Char -> Char -> TokenizerM Text -detect2Chars dynamic c d = do +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 - inp <- gets input - if (Text.pack [c',d']) `Text.isPrefixOf` inp + if (encodeUtf8 (Text.pack [c',d'])) `BS.isPrefixOf` inp then takeChars 2 else mzero -rangeDetect :: Char -> Char -> TokenizerM Text -rangeDetect c d = do - inp <- gets input - case Text.uncons inp of +rangeDetect :: Char -> Char -> ByteString -> TokenizerM Text +rangeDetect c d inp = do + case UTF8.uncons inp of Just (x, rest) - | x == c -> case Text.span (/= d) rest of + | x == c -> case UTF8.span (/= d) rest of (in_t, out_t) - | Text.null out_t -> mzero - | otherwise -> takeChars (Text.length in_t + 2) + | BS.null out_t -> mzero + | otherwise -> do + t <- decodeBS in_t + takeChars (Text.length t + 2) _ -> mzero -detectSpaces :: TokenizerM Text -detectSpaces = do - inp <- gets input - case Text.span isSpace inp of +-- NOTE: currently limited to ASCII +detectSpaces :: ByteString -> TokenizerM Text +detectSpaces inp = do + case BS.span (\c -> isSpace c) inp of (t, _) - | Text.null t -> mzero - | otherwise -> takeChars (Text.length t) + | BS.null t -> mzero + | otherwise -> takeChars (BS.length t) -detectIdentifier :: TokenizerM Text -detectIdentifier = do - inp <- gets input - case Text.uncons inp of +-- NOTE: limited to ASCII as per kate documentation +detectIdentifier :: ByteString -> TokenizerM Text +detectIdentifier inp = do + case BS.uncons inp of Just (c, t) | isLetter c || c == '_' -> - takeChars $ 1 + maybe 0 id (Text.findIndex (\d -> - not (isAlphaNum d || d == '_')) t) + takeChars $ 1 + maybe 0 id (BS.findIndex + (\d -> not (isAlphaNum d || d == '_')) t) _ -> mzero -lineContinue :: TokenizerM Text -lineContinue = do - inp <- gets input +lineContinue :: ByteString -> TokenizerM Text +lineContinue inp = do if inp == "\\" then do modify $ \st -> st{ lineContinuation = True } takeChars 1 else mzero -anyChar :: [Char] -> TokenizerM Text -anyChar cs = do - inp <- gets input - case Text.uncons inp of +anyChar :: [Char] -> ByteString -> TokenizerM Text +anyChar cs inp = do + case UTF8.uncons inp of Just (x, _) | x `elem` cs -> takeChars 1 _ -> mzero -regExpr :: Bool -> RE -> TokenizerM Text -regExpr dynamic re = do +regExpr :: Bool -> RE -> ByteString -> TokenizerM Text +regExpr dynamic re inp = do reStr <- if dynamic then subDynamic (reString re) else return (reString re) -- note, for dynamic regexes rCompiled == Nothing: let regex = fromMaybe (compileRegex (reCaseSensitive re) reStr) $ reCompiled re - inp <- gets input - prev <- gets prevChar -- If regex starts with \b, determine if we're at a word -- boundary and mzero if not (TODO - is this the correct -- definition of a word boundary?) when (BS.take 2 reStr == "\\b") $ - case Text.uncons inp of + case UTF8.uncons inp of Nothing -> return () - Just (c, _) - | isAlphaNum prev -> guard (not (isAlphaNum c)) - | otherwise -> guard (isAlphaNum c) - let target = encodeUtf8 inp - case matchRegex regex target of + Just (c, _) -> do + prev <- gets prevChar + if isAlphaNum prev + then guard (not (isAlphaNum c)) + else guard (isAlphaNum c) + case matchRegex regex inp of Just (match:capts) -> do match' <- decodeBS match - capts' <- mapM decodeBS capts - modify $ \st -> st{ captures = capts' } + modify $ \st -> st{ captures = capts } takeChars (Text.length match') _ -> mzero -decodeBS :: BS.ByteString -> TokenizerM Text +decodeBS :: ByteString -> TokenizerM Text decodeBS bs = case decodeUtf8' bs of Left _ -> throwError ("ByteString " ++ show bs ++ "is not UTF8") @@ -429,7 +436,7 @@ -- Substitute out %1, %2, etc. in regex string, escaping -- appropriately.. -subDynamic :: BS.ByteString -> TokenizerM BS.ByteString +subDynamic :: ByteString -> TokenizerM ByteString subDynamic bs | BS.null bs = return BS.empty | otherwise = @@ -454,19 +461,19 @@ capts <- gets captures if length capts < capnum then mzero - else return $ capts !! (capnum - 1) + else decodeBS $ capts !! (capnum - 1) -keyword :: KeywordAttr -> WordSet Text -> TokenizerM Text -keyword kwattr kws = do +keyword :: KeywordAttr -> WordSet Text -> ByteString -> TokenizerM Text +keyword kwattr kws inp = do prev <- gets prevChar guard $ prev `Set.member` (keywordDelims kwattr) - inp <- gets input - let (w,_) = Text.break (`Set.member` (keywordDelims kwattr)) inp - guard $ not (Text.null w) - let numchars = Text.length w + let (w,_) = UTF8.break (`Set.member` (keywordDelims kwattr)) inp + guard $ not (BS.null w) + w' <- decodeBS w + let numchars = Text.length w' case kws of - CaseSensitiveWords ws | w `Set.member` ws -> takeChars numchars - CaseInsensitiveWords ws | mk w `Set.member` ws -> takeChars numchars + CaseSensitiveWords ws | w' `Set.member` ws -> takeChars numchars + CaseInsensitiveWords ws | mk w' `Set.member` ws -> takeChars numchars _ -> mzero normalizeHighlighting :: [Token] -> [Token]