skylighting 0.5.0.1 → 0.5.1
raw patch · 6 files changed
+158/−50 lines, 6 filesdep +QuickCheckdep +tasty-quickcheck
Dependencies added: QuickCheck, tasty-quickcheck
Files
- README.md +1/−6
- bin/main.hs +2/−1
- changelog.md +19/−0
- skylighting.cabal +4/−1
- src/Skylighting/Tokenizer.hs +111/−29
- test/test-skylighting.hs +21/−13
README.md view
@@ -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 -----------------
bin/main.hs view
@@ -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)))
changelog.md view
@@ -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
skylighting.cabal view
@@ -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,
src/Skylighting/Tokenizer.hs view
@@ -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
test/test-skylighting.hs view
@@ -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