diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,21 @@ # Revision history for skylighting and skylighting-core +## 0.10.4 + + * Move from hxt to xml-conduit for XML parsing. + + This gives about a 4X speedup in parsing syntax definitions. + It also reduces the pandoc build dependency footprint, as we + depend on xml-conduit anyway and now no longer need to compile + HXT and its dependencies. + + There are improvements in accuracy as well: the change to + xml-conduit improved parsing for one of the prolog rules; + a matcher that should have been for tab characters had been set for a + space instead. + + * Removed some unnecessary build-depends in skylighting-extract. + ## 0.10.3 * Add support for raku (#114). diff --git a/skylighting-core.cabal b/skylighting-core.cabal --- a/skylighting-core.cabal +++ b/skylighting-core.cabal @@ -1,5 +1,5 @@ name: skylighting-core -version: 0.10.3 +version: 0.10.4 synopsis: syntax highlighting library description: Skylighting is a syntax highlighting library. It derives its tokenizers from XML syntax @@ -113,7 +113,7 @@ Regex.KDE.Regex Regex.KDE.Compile Regex.KDE.Match - other-extensions: CPP, Arrows + other-extensions: CPP build-depends: base >= 4.8 && < 5.0, mtl, transformers, @@ -126,12 +126,11 @@ case-insensitive, attoparsec, utf8-string, - hxt, + xml-conduit >= 1.9.1.0 && < 1.10, safe, base64-bytestring, blaze-html >= 0.5, containers >= 0.5.8.2, - utf8-string, ansi-terminal >= 0.7, colour >= 2.0 hs-source-dirs: src @@ -190,19 +189,10 @@ build-depends: base >= 4.8 && < 5.0, skylighting-core, filepath, - bytestring, - base64-bytestring, text, safe, - hxt, - utf8-string, - case-insensitive, - aeson >= 1.0, binary, - containers, - directory, - ansi-terminal >= 0.7, - colour >= 2.0 + directory if flag(executable) buildable: True else diff --git a/src/Skylighting/Parser.hs b/src/Skylighting/Parser.hs --- a/src/Skylighting/Parser.hs +++ b/src/Skylighting/Parser.hs @@ -1,28 +1,34 @@ -{-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} module Skylighting.Parser ( parseSyntaxDefinition - , parseSyntaxDefinitionFromString + , parseSyntaxDefinitionFromText , addSyntaxDefinition , missingIncludes ) where -import Data.ByteString.UTF8 (fromString, toString) -import qualified Data.ByteString as BS +import qualified Data.String as String +import qualified Data.ByteString.Lazy.Char8 as BL import Data.Char (isAlphaNum, toUpper) -import qualified Data.Map as Map +import qualified Data.Map as M import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Data.Text (Text) -import qualified Data.Text as Text +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import qualified Data.Text.Read as TR +import qualified Data.Text.Encoding as TE import Safe import Skylighting.Regex import Skylighting.Types import System.FilePath -import Text.XML.HXT.Core +import Text.XML +import qualified Control.Exception as E +import Control.Monad.Except -- | Adds a syntax definition to a syntax map, -- replacing any existing definition with the same name. addSyntaxDefinition :: Syntax -> SyntaxMap -> SyntaxMap -addSyntaxDefinition s = Map.insert (sName s) s +addSyntaxDefinition s = M.insert (sName s) s -- | Scan a list of 'Syntax's and make sure that -- `IncludeRules` never asks for a syntax not in this @@ -35,7 +41,7 @@ missingIncludes syns = ordNub [(sName s, lang) | s <- syns - , c <- Map.elems (sContexts s) + , c <- M.elems (sContexts s) , IncludeRules (lang, _) <- map rMatcher (cRules c) , not (lang `Set.member` syntaxNames)] where syntaxNames = Set.fromList $ map sName syns @@ -54,312 +60,297 @@ defaultKeywordAttr = KeywordAttr { keywordCaseSensitive = True , keywordDelims = standardDelims } -stripWhitespace :: String -> String -stripWhitespace = reverse . stripWhitespaceLeft . reverse . stripWhitespaceLeft - where stripWhitespaceLeft = dropWhile isWhitespace - isWhitespace x = x `elem` [' ', '\t', '\n'] - -vBool :: Bool -> String -> Bool +vBool :: Bool -> Text -> Bool vBool defaultVal value = case value of - z | z `elem` ["true","yes","1"] -> True - z | z `elem` ["false","no","0"] -> False - _ -> defaultVal + "true" -> True + "yes" -> True + "1" -> True + "false" -> False + "no" -> False + "0" -> False + _ -> defaultVal -- | Parses a file containing a Kate XML syntax definition --- into a 'Syntax' description. Note that if the DOCTYPE contains --- a reference to the now-obsolete language.dtd, we remove it. +-- into a 'Syntax' description. parseSyntaxDefinition :: FilePath -> IO (Either String Syntax) parseSyntaxDefinition fp = do - xml <- toString <$> BS.readFile fp - parseSyntaxDefinitionFromString fp xml + bs <- BL.readFile fp + return $ parseSyntaxDefinitionFromText fp (toTextLazy bs) + where + toTextLazy = TLE.decodeUtf8 . filterCRs . dropBOM + dropBOM bs = + if "\xEF\xBB\xBF" `BL.isPrefixOf` bs + then BL.drop 3 bs + else bs + filterCRs = BL.filter (/='\r') --- | Parses a string containing a Kate XML syntax definition --- into a 'Syntax' description. Note that if the DOCTYPE contains --- a reference to the now-obsolete language.dtd, we remove it. -parseSyntaxDefinitionFromString :: FilePath -- ^ used for short name - -> String - -> IO (Either String Syntax) -parseSyntaxDefinitionFromString fp xml = do - res <- runX ( readString [withValidate no] - (removeLanguageDTD . removeBOM $ xml) - >>> - application fp ) - case res of - [s] -> return $ Right s - _ -> return $ Left $ "Could not parse syntax definition " ++ fp +parseSyntaxDefinitionFromText :: + FilePath -> TL.Text -> Either String Syntax +parseSyntaxDefinitionFromText fp xml = + case parseText def xml of + Left e -> Left $ E.displayException e + Right doc -> runExcept $ documentToSyntax fp doc -removeBOM :: String -> String -removeBOM ('\xFEFF':xs) = xs -removeBOM xs = xs +-- | Parses an XML 'Document' as a 'Syntax' description. +documentToSyntax :: FilePath -- ^ used for short name + -> Document + -> Except String Syntax +documentToSyntax fp Document{ documentRoot = rootEl } = do + unless (elementName rootEl == "language") $ + throwError "Root element is not language" + let filename = takeFileName fp + let casesensitive = vBool True $ getAttrValue "casesensitive" rootEl -removeLanguageDTD :: String -> String -removeLanguageDTD ('S':'Y':'S':'T':'E':'M':' ':xs) = - removeLanguageDTD $ dropWhile (\c -> c /= '[' && c /= '>') xs -removeLanguageDTD xs@('<':'l':'a':'n':'g':_) = xs -removeLanguageDTD (x:xs) = x : removeLanguageDTD xs -removeLanguageDTD [] = [] + hlEl <- case getElementsNamed "highlighting" rootEl of + [] -> throwError "No highlighting element" + (hl:_) -> return hl -application :: FilePath -> IOSArrow XmlTree Syntax -application fp - = multi (hasName "language") - >>> - extractSyntaxDefinition (takeFileName fp) + lists <- M.fromList <$> mapM getList (getElementsNamed "list" hlEl) -extractSyntaxDefinition :: String -> IOSArrow XmlTree Syntax -extractSyntaxDefinition filename = - proc x -> do - lang <- getAttrValue "name" -< x - author <- getAttrValue "author" -< x - version <- getAttrValue "version" -< x - license <- getAttrValue "license" -< x - extensions <- getAttrValue "extensions" -< x - contexts <- getContexts $< - (arr (vBool True) <<< getAttrValue "casesensitive") &&& - (getAttrValue "name") &&& - (arr toItemDataTable <<< getItemDatas) &&& - getLists &&& - (arr (headDef defaultKeywordAttr) <<< getKeywordAttrs) -< x - startingContext <- case contexts of - (c:_) -> returnA -< cName c - [] -> issueErr "No contexts" >>> none -< () - returnA -< Syntax{ - sName = Text.pack lang - , sFilename = filename - , sShortname = Text.pack $ pathToLangName filename - , sAuthor = Text.pack $ author - , sVersion = Text.pack $ version - , sLicense = Text.pack $ license - , sExtensions = words $ map - (\c -> if c == ';' - then ' ' - else c) extensions - , sContexts = Map.fromList - [(cName c, c) | c <- contexts] - , sStartingContext = startingContext - } + let itemDatas = getItemData hlEl -toItemDataTable :: [(String,String)] -> Map.Map String TokenType -toItemDataTable = Map.fromList . map (\(s,t) -> (s, toTokenType t)) + let defKeywordAttr = getKeywordAttrs rootEl -getItemDatas :: IOSArrow XmlTree [(String,String)] -getItemDatas = - multi (hasName "itemDatas") - >>> - (listA $ getChildren - >>> - hasName "itemData" - >>> - getAttrValue "name" &&& getAttrValue "defStyleNum") + let contextEls = getElementsNamed "contexts" hlEl >>= + getElementsNamed "context" -toTokenType :: String -> TokenType -toTokenType s = - case s of - "dsNormal" -> NormalTok - "dsKeyword" -> KeywordTok - "dsDataType" -> DataTypeTok - "dsDecVal" -> DecValTok - "dsBaseN" -> BaseNTok - "dsFloat" -> FloatTok - "dsConstant" -> ConstantTok - "dsChar" -> CharTok - "dsSpecialChar" -> SpecialCharTok - "dsString" -> StringTok - "dsVerbatimString" -> VerbatimStringTok - "dsSpecialString" -> SpecialStringTok - "dsImport" -> ImportTok - "dsComment" -> CommentTok - "dsDocumentation" -> DocumentationTok - "dsAnnotation" -> AnnotationTok - "dsCommentVar" -> CommentVarTok - "dsOthers" -> OtherTok - "dsFunction" -> FunctionTok - "dsVariable" -> VariableTok - "dsControlFlow" -> ControlFlowTok - "dsOperator" -> OperatorTok - "dsBuiltIn" -> BuiltInTok - "dsExtension" -> ExtensionTok - "dsPreprocessor" -> PreprocessorTok - "dsAttribute" -> AttributeTok - "dsRegionMarker" -> RegionMarkerTok - "dsInformation" -> InformationTok - "dsWarning" -> WarningTok - "dsAlert" -> AlertTok - "dsError" -> ErrorTok - _ -> NormalTok + let syntaxname = getAttrValue "name" rootEl -getLists :: IOSArrow XmlTree [(String, [String])] -getLists = - listA $ multi (hasName "list") - >>> - getAttrValue "name" &&& getListContents + contexts <- mapM + (getContext casesensitive syntaxname itemDatas lists defKeywordAttr) + contextEls -getListContents :: IOSArrow XmlTree [String] -getListContents = - listA $ getChildren - >>> - hasName "item" - >>> - getChildren - >>> - getText - >>> - arr stripWhitespace + startingContext <- case contexts of + (c:_) -> return $ cName c + [] -> throwError "No contexts" -getContexts :: - (Bool, - (String, - (Map.Map String TokenType, - ([(String, [String])], KeywordAttr)))) - -> IOSArrow XmlTree [Context] -getContexts (casesensitive, (syntaxname, (itemdatas, (lists, kwattr)))) = - listA $ multi (hasName "context") - >>> - proc x -> do - name <- getAttrValue "name" -< x - attribute <- getAttrValue "attribute" -< x - lineEmptyContext <- getAttrValue "lineEmptyContext" -< x - lineEndContext <- getAttrValue "lineEndContext" -< x - lineBeginContext <- getAttrValue "lineBeginContext" -< x - fallthrough <- arr (vBool False) <<< getAttrValue "fallthrough" -< x - fallthroughContext <- getAttrValue "fallthroughContext" -< x - dynamic <- arr (vBool False) <<< getAttrValue "dynamic" -< x - parsers <- getParsers (casesensitive, (syntaxname, - (itemdatas, (lists, kwattr)))) $< - getAttrValue "attribute" -< x - returnA -< Context { - cName = Text.pack name - , cSyntax = Text.pack syntaxname - , cRules = parsers - , cAttribute = fromMaybe NormalTok $ - Map.lookup attribute itemdatas - , cLineEmptyContext = - parseContextSwitch syntaxname lineEmptyContext - , cLineEndContext = - parseContextSwitch syntaxname lineEndContext - , cLineBeginContext = - parseContextSwitch syntaxname lineBeginContext - , cFallthrough = fallthrough - , cFallthroughContext = - parseContextSwitch syntaxname fallthroughContext - , cDynamic = dynamic - } + return Syntax{ + sName = getAttrValue "name" rootEl + , sFilename = filename + , sShortname = T.pack $ pathToLangName filename + , sAuthor = getAttrValue "author" rootEl + , sVersion = getAttrValue "version" rootEl + , sLicense = getAttrValue "license" rootEl + , sExtensions = words $ map (\c -> if c == ';' then ' ' else c) + $ T.unpack + $ getAttrValue "extensions" rootEl + , sContexts = M.fromList + [(cName c, c) | c <- contexts] + , sStartingContext = startingContext + } --- Note, some xml files have "\\" for a backslash, --- others have "\". Not sure what the rules are, but --- this covers both bases: -readChar :: String -> Char -readChar s = case s of - [c] -> c - _ -> readDef '\xffff' $ "'" ++ s ++ "'" +elementNamed :: String -> Node -> Bool +elementNamed name (NodeElement el) = elementName el == String.fromString name +elementNamed _ _ = False +getElementsNamed :: String -> Element -> [Element] +getElementsNamed name node = + [el | NodeElement el <- filter (elementNamed name) (elementNodes node)] -getParsers :: (Bool, - (String, - (Map.Map String TokenType, - ([(String, [String])], KeywordAttr)))) - -> String -- context attribute - -> IOSArrow XmlTree [Rule] -getParsers (casesensitive, (syntaxname, (itemdatas, (lists, kwattr)))) cattr = - listA $ getChildren - >>> - proc x -> do - name <- getName -< x - attribute <- getAttrValue "attribute" -< x - context <- getAttrValue "context" -< x - char0 <- arr readChar <<< getAttrValue "char" -< x - char1 <- arr readChar <<< getAttrValue "char1" -< x - str' <- getAttrValue "String" -< x - insensitive <- arr (vBool (not casesensitive)) - <<< getAttrValue "insensitive" -< x - includeAttrib <- arr (vBool False) <<< getAttrValue "includeAttrib" -< x - lookahead <- arr (vBool False) <<< getAttrValue "lookAhead" -< x - firstNonSpace <- arr (vBool False) <<< getAttrValue "firstNonSpace" -< x - column' <- getAttrValue "column" -< x - dynamic <- arr (vBool False) <<< getAttrValue "dynamic" -< x - children <- getParsers - (casesensitive, (syntaxname, (itemdatas, (lists, kwattr)))) - cattr -< x - let tildeRegex = name == "RegExpr" && take 1 str' == "^" - let str = if tildeRegex then drop 1 str' else str' - let column = if tildeRegex - then Just (0 :: Int) - else readMay column' - let re = RegExpr RE{ reString = fromString str - , reCaseSensitive = not insensitive } - let (incsyntax, inccontext) = - case break (=='#') context of - (cont, '#':'#':lang) -> (lang, cont) - _ -> (syntaxname, context) - let mbmatcher = case name of - "DetectChar" -> Just $ DetectChar char0 - "Detect2Chars" -> Just $ Detect2Chars char0 char1 - "AnyChar" -> Just $ AnyChar $ Set.fromList str - "RangeDetect" -> Just $ RangeDetect char0 char1 - "StringDetect" -> Just $ StringDetect $ Text.pack str - "WordDetect" -> Just $ WordDetect $ Text.pack str - "RegExpr" -> Just $ re - "keyword" -> Just $ Keyword kwattr $ - maybe (makeWordSet True []) - (makeWordSet (keywordCaseSensitive kwattr) . map Text.pack) - (lookup str lists) - "Int" -> Just $ Int - "Float" -> Just $ Float - "HlCOct" -> Just $ HlCOct - "HlCHex" -> Just $ HlCHex - "HlCStringChar" -> Just $ HlCStringChar - "HlCChar" -> Just $ HlCChar - "LineContinue" -> Just $ LineContinue - "IncludeRules" -> Just $ - IncludeRules (Text.pack incsyntax, Text.pack inccontext) - "DetectSpaces" -> Just $ DetectSpaces - "DetectIdentifier" -> Just $ DetectIdentifier - _ -> Nothing +getAttrValue :: String -> Element -> Text +getAttrValue key el = fromMaybe mempty $ M.lookup (String.fromString key) + $ elementAttributes el - matcher <- case mbmatcher of - Nothing -> none - <<< applyA (arr issueWarn) - <<< arr ("Unknown element " ++) - <<< getName -< x - Just m -> returnA -< m +getTextContent :: Element -> Text +getTextContent el = + mconcat [t | NodeContent t <- elementNodes el] - let contextSwitch = if name == "IncludeRules" - then [] -- is this right? - else parseContextSwitch incsyntax inccontext - returnA -< Rule{ rMatcher = matcher, - rAttribute = fromMaybe NormalTok $ - if null attribute - then Map.lookup cattr itemdatas - else Map.lookup attribute itemdatas, - rIncludeAttribute = includeAttrib, - rDynamic = dynamic, - rCaseSensitive = not insensitive, - rChildren = children, - rContextSwitch = contextSwitch, - rLookahead = lookahead, - rFirstNonspace = firstNonSpace , - rColumn = column } +getList :: Element -> Except String (Text, [Text]) +getList el = do + case M.lookup "name" (elementAttributes el) of + Nothing -> throwError "No name attribute on list" + Just name -> + return (name, map (T.strip . getTextContent) + (getElementsNamed "item" el)) -parseContextSwitch :: String -> String -> [ContextSwitch] -parseContextSwitch _ [] = [] -parseContextSwitch _ "#stay" = [] -parseContextSwitch syntaxname ('#':'p':'o':'p':xs) = - Pop : parseContextSwitch syntaxname xs -parseContextSwitch syntaxname ('!':xs) = [Push (Text.pack syntaxname, Text.pack xs)] -parseContextSwitch syntaxname xs = [Push (Text.pack syntaxname, Text.pack xs)] +getParser :: Bool -> Text -> ItemData -> M.Map Text [Text] -> KeywordAttr + -> Text -> Element -> Except String Rule +getParser casesensitive syntaxname itemdatas lists kwattr cattr el = do + let name = nameLocalName . elementName $ el + let attribute = getAttrValue "attribute" el + let context = getAttrValue "context" el + let char0 = readChar $ getAttrValue "char" el + let char1 = readChar $ getAttrValue "char1" el + let str' = getAttrValue "String" el + let insensitive = vBool (not casesensitive) $ getAttrValue "insensitive" el + let includeAttrib = vBool False $ getAttrValue "includeAttrib" el + let lookahead = vBool False $ getAttrValue "lookAhead" el + let firstNonSpace = vBool False $ getAttrValue "firstNonSpace" el + let column' = getAttrValue "column" el + let dynamic = vBool False $ getAttrValue "dynamic" el + children <- mapM (getParser casesensitive + syntaxname itemdatas lists kwattr attribute) + [e | NodeElement e <- elementNodes el ] + let tildeRegex = name == "RegExpr" && T.take 1 str' == "^" + let str = if tildeRegex then T.drop 1 str' else str' + let column = if tildeRegex + then Just (0 :: Int) + else either (\_ -> Nothing) (Just . fst) $ + TR.decimal column' + let re = RegExpr RE{ reString = TE.encodeUtf8 str + , reCaseSensitive = not insensitive } + let (incsyntax, inccontext) = + case T.breakOn "##" context of + (_,x) | T.null x -> (syntaxname, context) + (cont, lang) -> (T.drop 2 lang, cont) + matcher <- case name of + "DetectChar" -> return $ DetectChar char0 + "Detect2Chars" -> return $ Detect2Chars char0 char1 + "AnyChar" -> return $ AnyChar $ Set.fromList $ T.unpack str + "RangeDetect" -> return $ RangeDetect char0 char1 + "StringDetect" -> return $ StringDetect str + "WordDetect" -> return $ WordDetect str + "RegExpr" -> return $ re + "keyword" -> return $ Keyword kwattr $ + maybe (makeWordSet True []) + (makeWordSet (keywordCaseSensitive kwattr)) + (M.lookup str lists) + "Int" -> return $ Int + "Float" -> return $ Float + "HlCOct" -> return $ HlCOct + "HlCHex" -> return $ HlCHex + "HlCStringChar" -> return $ HlCStringChar + "HlCChar" -> return $ HlCChar + "LineContinue" -> return $ LineContinue + "IncludeRules" -> return $ + IncludeRules (incsyntax, inccontext) + "DetectSpaces" -> return $ DetectSpaces + "DetectIdentifier" -> return $ DetectIdentifier + _ -> throwError $ "Unknown element " ++ T.unpack name -getKeywordAttrs :: IOSArrow XmlTree [KeywordAttr] -getKeywordAttrs = - listA $ multi $ hasName "keywords" - >>> - proc x -> do - caseSensitive <- arr (vBool True) <<< getAttrValue "casesensitive" -< x - weakDelim <- getAttrValue "weakDeliminator" -< x - additionalDelim <- getAttrValue "additionalDeliminator" -< x - returnA -< KeywordAttr - { keywordCaseSensitive = caseSensitive - , keywordDelims = (Set.union standardDelims - (Set.fromList additionalDelim)) Set.\\ - Set.fromList weakDelim } + let contextSwitch = if name == "IncludeRules" + then [] -- is this right? + else parseContextSwitch incsyntax inccontext + return $ Rule{ rMatcher = matcher + , rAttribute = fromMaybe NormalTok $ + if T.null attribute + then M.lookup cattr itemdatas + else M.lookup attribute itemdatas + , rIncludeAttribute = includeAttrib + , rDynamic = dynamic + , rCaseSensitive = not insensitive + , rChildren = children + , rContextSwitch = contextSwitch + , rLookahead = lookahead + , rFirstNonspace = firstNonSpace + , rColumn = column + } + + +getContext :: Bool + -> Text + -> ItemData + -> M.Map Text [Text] + -> KeywordAttr + -> Element + -> Except String Context +getContext casesensitive syntaxname itemDatas lists kwattr el = do + let name = getAttrValue "name" el + let attribute = getAttrValue "attribute" el + let lineEmptyContext = getAttrValue "lineEmptyContext" el + let lineEndContext = getAttrValue "lineEndContext" el + let lineBeginContext = getAttrValue "lineBeginContext" el + let fallthrough = vBool False $ getAttrValue "fallthrough" el + let fallthroughContext = getAttrValue "fallthroughContext" el + let dynamic = vBool False $ getAttrValue "dynamic" el + + parsers <- mapM (getParser casesensitive + syntaxname itemDatas lists kwattr attribute) + [e | NodeElement e <- elementNodes el ] + + return $ Context { + cName = name + , cSyntax = syntaxname + , cRules = parsers + , cAttribute = fromMaybe NormalTok $ M.lookup attribute itemDatas + , cLineEmptyContext = + parseContextSwitch syntaxname lineEmptyContext + , cLineEndContext = + parseContextSwitch syntaxname lineEndContext + , cLineBeginContext = + parseContextSwitch syntaxname lineBeginContext + , cFallthrough = fallthrough + , cFallthroughContext = + parseContextSwitch syntaxname fallthroughContext + , cDynamic = dynamic + } + +getItemData :: Element -> ItemData +getItemData el = toItemDataTable $ + [(getAttrValue "name" e, getAttrValue "defStyleNum" e) + | e <- (getElementsNamed "itemDatas" el >>= getElementsNamed "itemData") + ] + +getKeywordAttrs :: Element -> KeywordAttr +getKeywordAttrs el = + case (getElementsNamed "general" el >>= getElementsNamed "keywords") of + [] -> defaultKeywordAttr + (x:_) -> + let weakDelim = T.unpack $ getAttrValue "weakDeliminator" x + additionalDelim = T.unpack $ getAttrValue "additionalDeliminator" x + in KeywordAttr { keywordCaseSensitive = + vBool True $ getAttrValue "casesensitive" x + , keywordDelims = Set.union standardDelims + (Set.fromList additionalDelim) Set.\\ + Set.fromList weakDelim } + +parseContextSwitch :: Text -> Text -> [ContextSwitch] +parseContextSwitch syntaxname t = + if T.null t || t == "#stay" + then [] + else + case T.stripPrefix "#pop" t of + Just rest -> Pop : parseContextSwitch syntaxname rest + Nothing -> [Push (syntaxname, T.dropWhile (=='!') t)] + +type ItemData = M.Map Text TokenType + +toItemDataTable :: [(Text, Text)] -> ItemData +toItemDataTable = M.fromList . map (\(s,t) -> (s, toTokenType t)) + +toTokenType :: Text -> TokenType +toTokenType t = + case t of + "dsNormal" -> NormalTok + "dsKeyword" -> KeywordTok + "dsDataType" -> DataTypeTok + "dsDecVal" -> DecValTok + "dsBaseN" -> BaseNTok + "dsFloat" -> FloatTok + "dsConstant" -> ConstantTok + "dsChar" -> CharTok + "dsSpecialChar" -> SpecialCharTok + "dsString" -> StringTok + "dsVerbatimString" -> VerbatimStringTok + "dsSpecialString" -> SpecialStringTok + "dsImport" -> ImportTok + "dsComment" -> CommentTok + "dsDocumentation" -> DocumentationTok + "dsAnnotation" -> AnnotationTok + "dsCommentVar" -> CommentVarTok + "dsOthers" -> OtherTok + "dsFunction" -> FunctionTok + "dsVariable" -> VariableTok + "dsControlFlow" -> ControlFlowTok + "dsOperator" -> OperatorTok + "dsBuiltIn" -> BuiltInTok + "dsExtension" -> ExtensionTok + "dsPreprocessor" -> PreprocessorTok + "dsAttribute" -> AttributeTok + "dsRegionMarker" -> RegionMarkerTok + "dsInformation" -> InformationTok + "dsWarning" -> WarningTok + "dsAlert" -> AlertTok + "dsError" -> ErrorTok + _ -> NormalTok + +-- Note, some xml files have "\\" for a backslash, +-- others have "\". Not sure what the rules are, but +-- this covers both bases: +readChar :: Text -> Char +readChar t = case T.unpack t of + [c] -> c + s -> readDef '\xffff' $ "'" ++ s ++ "'" pathToLangName :: String -> String pathToLangName s = capitalize (camelize (takeBaseName s)) diff --git a/test/expected/abc.prolog.native b/test/expected/abc.prolog.native --- a/test/expected/abc.prolog.native +++ b/test/expected/abc.prolog.native @@ -50,9 +50,7 @@ , ( KeywordTok , "->" ) , ( NormalTok , " format(" ) , ( StringTok , "'~" ) - , ( ErrorTok , "w" ) - , ( AlertTok , " " ) - , ( ErrorTok , "OK" ) + , ( ErrorTok , "w OK" ) , ( StringTok , "~" ) , ( ErrorTok , "n" ) , ( StringTok , "'" ) @@ -65,9 +63,7 @@ , ( KeywordTok , ";" ) , ( NormalTok , " format(" ) , ( StringTok , "'~" ) - , ( ErrorTok , "w" ) - , ( AlertTok , " " ) - , ( ErrorTok , "KO" ) + , ( ErrorTok , "w KO" ) , ( StringTok , "~" ) , ( ErrorTok , "n" ) , ( StringTok , "'" ) diff --git a/test/test-skylighting.hs b/test/test-skylighting.hs --- a/test/test-skylighting.hs +++ b/test/test-skylighting.hs @@ -8,7 +8,9 @@ import Data.Algorithm.Diff import qualified Data.ByteString.Lazy as BL import qualified Data.Map as Map -import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>), Semigroup) +#endif import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text