skylighting 0.1.1 → 0.1.1.1
raw patch · 4 files changed
+192/−130 lines, 4 filesdep +criteriondep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: criterion
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- benchmark/benchmark.hs +33/−0
- changelog.md +6/−0
- skylighting.cabal +17/−1
- src/Skylighting/Tokenizer.hs +136/−129
+ benchmark/benchmark.hs view
@@ -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)+
changelog.md view
@@ -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.+
skylighting.cabal view
@@ -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
src/Skylighting/Tokenizer.hs view
@@ -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]