diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -53,16 +53,11 @@ definitions from the `xml` directory and writes Haskell source files. In the second we actually build the library. -Using stack: - - make bootstrap - make - Using cabal: cabal install -fbootstrap --disable-optimization cabal run skylighting-extract -- xml/*.xml - cabal install -f-bootstrap --disable-optimization + cabal install -f-bootstrap Command-line tool ----------------- diff --git a/bin/main.hs b/bin/main.hs --- a/bin/main.hs +++ b/bin/main.hs @@ -163,13 +163,14 @@ syntaxMap' <- foldr addSyntaxDefinition defaultSyntaxMap <$> extractDefinitions opts +{- case missingIncludes (Map.elems syntaxMap') of [] -> return () xs -> err $ "Missing syntax definitions:\n" ++ unlines (map (\(syn,dep) -> (Text.unpack syn ++ " requires " ++ Text.unpack dep ++ " through IncludeRules.")) xs) - +-} when (List `elem` opts) $ do let printSyntaxNames s = putStrLn (printf "%s (%s)" (Text.unpack (Text.toLower (sShortname s))) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,24 @@ # Revision history for skylighting +## 0.5.1 -- 2018-01-07 + + * Fixed tokenizer exceptions (#31). Previously `throwError` + did not actually generate `Left` results in `tokenize`, + because of the way the MonadPlus instance worked. Rewrote + the TokenizerM monad from scratch so that exceptions would + not be skipped. + + * Improved error message about undefined contexts. + + * Makefile: use cabal for bootstrap target. + + * README: remove stack bootstrap instructions. + You can no longer bootstrap with stack, because it + insists on building ALL the executables the first time, + and of course that can't be done with this library. + + * Use quickcheck for fuzz test. + ## 0.5.0.1 -- 2017-12-18 * Small improvements to fuzz tests in test suite. We now diff --git a/skylighting.cabal b/skylighting.cabal --- a/skylighting.cabal +++ b/skylighting.cabal @@ -1,5 +1,5 @@ name: skylighting -version: 0.5.0.1 +version: 0.5.1 synopsis: syntax highlighting library description: Skylighting is a syntax highlighting library with support for over one hundred languages. It derives @@ -327,6 +327,7 @@ buildable: True else buildable: False + other-modules: Paths_skylighting test-suite test-skylighting type: exitcode-stdio-1.0 @@ -340,6 +341,8 @@ tasty, tasty-golden, tasty-hunit, + tasty-quickcheck, + QuickCheck, containers, random, Diff, diff --git a/src/Skylighting/Tokenizer.hs b/src/Skylighting/Tokenizer.hs --- a/src/Skylighting/Tokenizer.hs +++ b/src/Skylighting/Tokenizer.hs @@ -1,4 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveFunctor #-} module Skylighting.Tokenizer ( tokenize , TokenizerConfig(..) @@ -26,18 +32,6 @@ import Skylighting.Types import Text.Printf (printf) -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 stack) - newtype ContextStack = ContextStack{ unContextStack :: [Context] } deriving (Show) @@ -59,9 +53,107 @@ , traceOutput :: Bool -- ^ Generate trace output for debugging } deriving (Show) -type TokenizerM = - ExceptT String (ReaderT TokenizerConfig (State TokenizerState)) +data Result e a = Success a + | Failure + | Error e + deriving (Functor) +deriving instance (Show a, Show e) => Show (Result e a) + +data 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 (\c s -> x (f c) s) + +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'. +tokenize :: TokenizerConfig -> Syntax -> Text -> Either String [SourceLine] +tokenize config syntax inp = + case runTokenizerM action config initState 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..]) + initState = startingState{ endline = Text.null inp + , contextStack = + case lookupContext + (sStartingContext syntax) syntax of + Just c -> ContextStack [c] + Nothing -> ContextStack [] } + + +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 stack) + popContextStack :: TokenizerM () popContextStack = do ContextStack cs <- gets contextStack @@ -110,20 +202,6 @@ else lookupContext (sStartingContext syntax) syntax lookupContext name syntax = Map.lookup name $ sContexts syntax --- | Tokenize some text using 'Syntax'. -tokenize :: TokenizerConfig -> Syntax -> Text -> Either String [SourceLine] -tokenize config syntax inp = - evalState - (runReaderT - (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] - Nothing -> ContextStack [] } - startingState :: TokenizerState startingState = TokenizerState{ input = BS.empty @@ -320,7 +398,11 @@ 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) + Nothing -> do + cur <- currentContext + throwError $ Text.unpack (cSyntax cur) ++ + " tokenizer requires undefined context " ++ + Text.unpack con ++ "##" ++ Text.unpack syn Just c -> do mbtok <- msum (map (\r -> tryRule r inp) (cRules c)) return $ case (mbtok, mbattr) of diff --git a/test/test-skylighting.hs b/test/test-skylighting.hs --- a/test/test-skylighting.hs +++ b/test/test-skylighting.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,9 +18,10 @@ import Test.Tasty import Test.Tasty.Golden.Advanced (goldenTest) import Test.Tasty.HUnit +import Test.Tasty.QuickCheck(testProperty) +import Test.QuickCheck import Text.Show.Pretty import qualified Data.Map as Map -import System.Random syntaxes :: [Syntax] syntaxes = Map.elems defaultSyntaxMap @@ -33,9 +35,6 @@ main :: IO () main = do - stdgen <- newStdGen - let randomTexts = (Text.chunksOf 250 . Text.unlines . Text.chunksOf 31 . - Text.pack . take 10000) $ randomRs ('\0','\160') stdgen inputs <- filter (\fp -> take 1 fp /= ".") <$> getDirectoryContents ("test" "cases") allcases <- mapM (Text.readFile . (("test" "cases") )) inputs @@ -73,7 +72,8 @@ , 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 randomTexts) syntaxes + map (\syn -> testProperty (Text.unpack (sName syn)) (p_no_drop syn)) + syntaxes , testGroup "Regression tests" $ let perl = maybe (error "could not find Perl syntax") id (lookupSyntax "Perl" defaultSyntaxMap) @@ -152,9 +152,19 @@ where notBoth (Both _ _ ) = False notBoth _ = True +instance Arbitrary Text where + arbitrary = Text.pack <$> arbitrary + shrink xs = Text.pack <$> shrink (Text.unpack xs) + +p_no_drop :: Syntax -> Text -> Bool +p_no_drop syntax t = + case tokenize defConfig syntax t of + Right ts -> Text.lines t == map (mconcat . map tokToText) ts + Left _ -> False + noDropTest :: [Text] -> Syntax -> TestTree noDropTest inps syntax = - localOption (mkTimeout 6000000) + localOption (mkTimeout 9000000) $ testCase (Text.unpack (sName syntax)) $ mapM_ go inps where go inp = @@ -165,15 +175,13 @@ where inplines = Text.lines inp toklines = map (mconcat . map tokToText) ts diffs = makeDiff "expected" inplines toklines - Left e -> do - assert ("Unexpected error: " ++ e) - assert ("input = " ++ show inp)) - (\(e :: RegexException) -> do - assert (show e) - assert ("input = " ++ show inp)) + Left e -> + assertFailure ("Unexpected error: " ++ e ++ "\ninput = " ++ show inp)) + (\(e :: RegexException) -> + assertFailure (show e ++ "\ninput = " ++ show inp)) tokenizerTest :: Bool -> FilePath -> TestTree -tokenizerTest regen inpFile = localOption (mkTimeout 6000000) $ +tokenizerTest regen inpFile = localOption (mkTimeout 9000000) $ goldenTest testname getExpected getActual (compareValues referenceFile) updateGolden where testname = lang ++ " tokenizing of " ++ inpFile