diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,6 +29,9 @@ dynamically. It is also now possible to convert `.theme` files directly into styles. +Skylighting is also faster than highlighting-kate, by a +factor of 3 in some cases. + Installing ---------- diff --git a/benchmark/benchmark.hs b/benchmark/benchmark.hs --- a/benchmark/benchmark.hs +++ b/benchmark/benchmark.hs @@ -2,14 +2,11 @@ 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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -20,3 +20,12 @@ and often better. * Added benchmarks. +## 0.1.1.2 -- 2017-01-28 + +* Added much more extensive testing to ensure that tokenizers + don't hang or drop input. +* Fixed some issues with line-end and fallthrough context + handling. +* Fixed a bug in WordDetect handling which caused it to drop + input (#2). + diff --git a/skylighting.cabal b/skylighting.cabal --- a/skylighting.cabal +++ b/skylighting.cabal @@ -1,5 +1,5 @@ name: skylighting -version: 0.1.1.1 +version: 0.1.1.2 synopsis: syntax highlighting library description: Skylighting is a syntax highlighting library with support for over one hundred languages. It derives @@ -51,6 +51,7 @@ test/cases/archive.rhtml test/cases/life.lua test/cases/hk91.html + test/cases/if.cmake test/expected/abc.ada.native test/expected/abc.agda.native test/expected/abc.c.native @@ -80,6 +81,7 @@ test/expected/archive.rhtml.native test/expected/life.lua.native test/expected/hk91.html.native + test/expected/if.cmake.native cabal-version: >=1.10 @@ -320,6 +322,8 @@ tasty, tasty-golden, tasty-hunit, + containers, + random, Diff, text, pretty-show, @@ -327,7 +331,6 @@ bytestring, directory, filepath, - QuickCheck, skylighting default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Skylighting/Tokenizer.hs b/src/Skylighting/Tokenizer.hs --- a/src/Skylighting/Tokenizer.hs +++ b/src/Skylighting/Tokenizer.hs @@ -41,6 +41,7 @@ data TokenizerState = TokenizerState{ input :: ByteString + , endline :: Bool , prevChar :: Char , contextStack :: ContextStack , captures :: [ByteString] @@ -62,16 +63,21 @@ popContextStack = do ContextStack cs <- gets contextStack case cs of - [] -> throwError "Empty context stack" -- programming error - (_:[]) -> return () -- don't pop last context + [] -> throwError "Empty context stack (the impossible happened)" + -- programming error + (_:[]) -> return () (_:rest) -> do modify (\st -> st{ contextStack = ContextStack rest }) + currentContext >>= checkLineEnd infoContextStack pushContextStack :: Context -> TokenizerM () pushContextStack cont = do modify (\st -> st{ contextStack = ContextStack (cont : unContextStack (contextStack st)) } ) + -- not sure why we need this in pop but not here, but if we + -- put it here we can get loops... + -- checkLineEnd cont infoContextStack currentContext :: TokenizerM Context @@ -81,21 +87,19 @@ [] -> throwError "Empty context stack" -- programming error (c:_) -> return c -doContextSwitch :: [ContextSwitch] -> TokenizerM () -doContextSwitch [] = return () -doContextSwitch (Pop : xs) = do - popContextStack - currentContext >>= checkLineEnd - doContextSwitch xs -doContextSwitch (Push (syn,c) : xs) = do +doContextSwitch :: ContextSwitch -> TokenizerM () +doContextSwitch Pop = popContextStack +doContextSwitch (Push (syn,c)) = do syntaxes <- asks syntaxMap case Map.lookup syn syntaxes >>= lookupContext c of - Just con -> do - pushContextStack con - checkLineEnd con - doContextSwitch xs + Just con -> pushContextStack con Nothing -> throwError $ "Unknown syntax or context: " ++ show (syn, c) +doContextSwitches :: [ContextSwitch] -> TokenizerM () +doContextSwitches [] = return () +doContextSwitches xs = do + mapM_ doContextSwitch xs + lookupContext :: Text -> Syntax -> Maybe Context lookupContext name syntax | Text.null name = if Text.null (sStartingContext syntax) @@ -111,6 +115,7 @@ (runExceptT (mapM tokenizeLine $ zip (BS.lines $ encodeUtf8 inp) [1..])) config) startingState{ input = encodeUtf8 inp + , endline = Text.null inp , contextStack = case lookupContext (sStartingContext syntax) syntax of Just c -> ContextStack [c] @@ -119,6 +124,7 @@ startingState :: TokenizerState startingState = TokenizerState{ input = BS.empty + , endline = True , prevChar = '\n' , contextStack = ContextStack [] , captures = [] @@ -129,6 +135,7 @@ tokenizeLine :: (ByteString, Int) -> TokenizerM [Token] tokenizeLine (ln, linenum) = do + modify $ \st -> st{ input = ln, endline = BS.null ln, prevChar = '\n' } cur <- currentContext lineCont <- gets lineContinuation if lineCont @@ -137,14 +144,13 @@ modify $ \st -> st{ column = 0 , firstNonspaceColumn = BS.findIndex (not . isSpace) ln } - doContextSwitch (cLineBeginContext cur) + doContextSwitches (cLineBeginContext cur) if BS.null ln - then doContextSwitch (cLineEmptyContext cur) - else doContextSwitch (cLineBeginContext cur) - modify $ \st -> st{ input = ln, prevChar = '\n' } + then doContextSwitches (cLineEmptyContext cur) + else doContextSwitches (cLineBeginContext cur) ts <- normalizeHighlighting . catMaybes <$> many getToken - inp <- gets input - if BS.null inp + eol <- gets endline + if eol then do currentContext >>= checkLineEnd return ts @@ -156,11 +162,16 @@ getToken :: TokenizerM (Maybe Token) getToken = do inp <- gets input - guard $ not (BS.null inp) + gets endline >>= guard . not context <- currentContext msum (map (\r -> tryRule r inp) (cRules context)) <|> if cFallthrough context - then doContextSwitch (cFallthroughContext context) >> getToken + then do + let fallthroughContext = case cFallthroughContext context of + [] -> [Pop] + cs -> cs + doContextSwitches fallthroughContext + getToken else (\x -> Just (cAttribute context, x)) <$> normalChunk takeChars :: Int -> TokenizerM Text @@ -171,6 +182,7 @@ 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 } return t @@ -226,13 +238,15 @@ Nothing -> return Nothing Just (tt, s) | rLookahead rule -> do - (oldinput, oldprevChar, oldColumn) <- + (oldinput, oldendline, oldprevChar, oldColumn) <- case oldstate of Nothing -> throwError "oldstate not saved with lookahead rule" Just st -> return - (input st, prevChar st, column st) + (input st, endline st, + prevChar st, column st) modify $ \st -> st{ input = oldinput + , endline = oldendline , prevChar = oldprevChar , column = oldColumn } return Nothing @@ -242,7 +256,7 @@ Just (_, cresult) -> return $ Just (tt, s <> cresult) info $ takeWhile (/=' ') (show (rMatcher rule)) ++ " MATCHED " ++ show mbtok' - doContextSwitch (rContextSwitch rule) + doContextSwitches (rContextSwitch rule) return mbtok' withAttr :: TokenType -> TokenizerM Text -> TokenizerM (Maybe Token) @@ -270,25 +284,42 @@ } where reStr = "'(?:" <> reHlCStringChar <> "|[^'\\\\])'" +{- +-- Try a tokenizer and return to original state if it fails. +-- This is used when one tokenizer calls another. +try :: TokenizerM a -> TokenizerM a +try tokenizer' = do + origstate <- get + tokenizer' <|> (put origstate >> mzero) +-} + 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) - case UTF8.uncons inp of - Just (c, _) | not (isAlphaNum c) -> return res - _ -> mzero + wordBoundary inp + 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 $ if caseSensitive + then s == t + else mk s == mk t + guard $ not (Text.null 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 + guard $ isWordBoundary c d + takeChars (Text.length t) 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 (Text.length s) - else mzero + guard $ if caseSensitive + then s == t + else mk s == mk t + takeChars (Text.length s) -- This assumes that nothing significant will happen -- in the middle of a string of spaces or a string @@ -302,10 +333,10 @@ Nothing -> mzero Just (c, _) | c == ' ' -> - let (bs,_) = BS.span (==' ') inp + let bs = BS.takeWhile (==' ') inp in takeChars (BS.length bs) | isAscii c && isAlphaNum c -> - let (bs,_) = BS.span isAlphaNum inp + let bs = BS.takeWhile isAlphaNum inp in takeChars (BS.length bs) | otherwise -> takeChars 1 @@ -317,18 +348,21 @@ Nothing -> throwError $ "Context lookup failed " ++ show (syn, con) Just c -> do mbtok <- msum (map (\r -> tryRule r inp) (cRules c)) - checkLineEnd c return $ case (mbtok, mbattr) of - (Just (NormalTok, xs), Just attr) -> - Just (attr, xs) + (Just (NormalTok, xs), Just attr) -> Just (attr, xs) _ -> mbtok checkLineEnd :: Context -> TokenizerM () checkLineEnd c = do - inp <- gets input - when (BS.null inp) $ do - lineCont' <- gets lineContinuation - unless lineCont' $ doContextSwitch (cLineEndContext c) + if null (cLineEndContext c) + then return () + else do + eol <- gets endline + info $ "checkLineEnd for " ++ show (cName c) ++ " eol = " ++ show eol ++ " cLineEndContext = " ++ show (cLineEndContext c) + when eol $ do + lineCont' <- gets lineContinuation + unless lineCont' $ + doContextSwitches (cLineEndContext c) detectChar :: Bool -> Char -> ByteString -> TokenizerM Text detectChar dynamic c inp = do @@ -410,23 +444,26 @@ -- note, for dynamic regexes rCompiled == Nothing: let regex = fromMaybe (compileRegex (reCaseSensitive re) reStr) $ reCompiled re - -- 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 UTF8.uncons inp of - Nothing -> return () - Just (c, _) -> do - prev <- gets prevChar - if isAlphaNum prev - then guard (not (isAlphaNum c)) - else guard (isAlphaNum c) + when (BS.take 2 reStr == "\\b") $ wordBoundary inp case matchRegex regex inp of Just (match:capts) -> do match' <- decodeBS match modify $ \st -> st{ captures = capts } takeChars (Text.length match') _ -> mzero + +wordBoundary :: ByteString -> TokenizerM () +wordBoundary inp = do + case UTF8.uncons inp of + Nothing -> return () + Just (d, _) -> do + c <- gets prevChar + guard $ isWordBoundary c d + +-- TODO is this right? +isWordBoundary :: Char -> Char -> Bool +isWordBoundary c d = + (isAlphaNum c && not (isAlphaNum d)) || (isAlphaNum d && not (isAlphaNum c)) decodeBS :: ByteString -> TokenizerM Text decodeBS bs = case decodeUtf8' bs of diff --git a/test/cases/if.cmake b/test/cases/if.cmake new file mode 100644 --- /dev/null +++ b/test/cases/if.cmake @@ -0,0 +1,3 @@ +if(CMARK_TESTS and CMARK_SHARED) + add_subdirectory(api_test) +endif() diff --git a/test/expected/if.cmake.native b/test/expected/if.cmake.native new file mode 100644 --- /dev/null +++ b/test/expected/if.cmake.native @@ -0,0 +1,9 @@ +[ [ ( KeywordTok , "if" ) + , ( NormalTok , "(CMARK_TESTS and CMARK_SHARED)" ) + ] +, [ ( NormalTok , " " ) + , ( KeywordTok , "add_subdirectory" ) + , ( NormalTok , "(api_test)" ) + ] +, [ ( KeywordTok , "endif" ) , ( NormalTok , "()" ) ] +] diff --git a/test/test-skylighting.hs b/test/test-skylighting.hs --- a/test/test-skylighting.hs +++ b/test/test-skylighting.hs @@ -17,11 +17,28 @@ import Test.Tasty.Golden.Advanced (goldenTest) import Test.Tasty.HUnit import Text.Show.Pretty +import qualified Data.Map as Map +import System.Random +syntaxes :: [Syntax] +syntaxes = Map.elems defaultSyntaxMap + +defConfig :: TokenizerConfig +defConfig = TokenizerConfig{ traceOutput = False + , syntaxMap = defaultSyntaxMap } + +tokToText :: Token -> Text +tokToText (_, s) = s + main :: IO () main = do + stdgen <- newStdGen + let randomText = Text.unlines $ Text.chunksOf 31 + $ Text.pack $ take 5000 $ randomRs ('\0','\127') stdgen inputs <- filter (\fp -> take 1 fp /= ".") <$> getDirectoryContents ("test" "cases") + allcases <- mconcat <$> + mapM (Text.readFile . (("test" "cases") )) inputs args <- getArgs let regen = "--regenerate" `elem` args defaultTheme <- BL.readFile ("test" "default.theme") @@ -51,6 +68,10 @@ ["Perl"] @=? map sName (syntaxesByFilename defaultSyntaxMap "foo/bar.pl") ] + , testGroup "Doesn't hang or drop text on a mixed syntax sample" $ + map (noDropTest allcases) syntaxes + , testGroup "Doesn't hang or drop text on fuzz" $ + map (noDropTest randomText) syntaxes , testGroup "Regression tests" $ [ testCase "perl quoting case" $ Right [ [ ( KeywordTok , "my" ) @@ -83,11 +104,27 @@ compareValues referenceFile expected actual = if expected == actual then return $ Nothing - else return $ Just $ unlines $ - [ "--- " ++ referenceFile - , "+++ actual" ] ++ - map (Text.unpack . vividize) - (getDiff (Text.lines expected) (Text.lines actual)) + else return $ Just $ makeDiff referenceFile + (Text.lines expected) (Text.lines actual) + +makeDiff :: FilePath -> [Text] -> [Text] -> String +makeDiff referenceFile expected actual = unlines $ + [ "--- " ++ referenceFile + , "+++ actual" ] ++ + map (Text.unpack . vividize) (filter notBoth (getDiff expected actual)) + where notBoth (Both _ _ ) = False + notBoth _ = True + +noDropTest :: Text -> Syntax -> TestTree +noDropTest inp syntax = localOption (mkTimeout 1000000) $ + testCase (Text.unpack (sName syntax)) $ + case tokenize defConfig syntax inp of + Right ts -> assertBool ("Text has been dropped:\n" ++ diffs) + (inplines == toklines) + where inplines = Text.lines inp + toklines = map (mconcat . map tokToText) ts + diffs = makeDiff "expected" inplines toklines + Left e -> assert ("Unexpected error: " ++ e) tokenizerTest :: Bool -> FilePath -> TestTree tokenizerTest regen inpFile = localOption (mkTimeout 1000000) $