skylighting-core 0.10.3 → 0.10.4
raw patch · 5 files changed
+308/−313 lines, 5 filesdep +xml-conduitdep −hxtdep ~containers
Dependencies added: xml-conduit
Dependencies removed: hxt
Dependency ranges changed: containers
Files
- changelog.md +16/−0
- skylighting-core.cabal +4/−14
- src/Skylighting/Parser.hs +283/−292
- test/expected/abc.prolog.native +2/−6
- test/test-skylighting.hs +3/−1
changelog.md view
@@ -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).
skylighting-core.cabal view
@@ -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
src/Skylighting/Parser.hs view
@@ -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))
test/expected/abc.prolog.native view
@@ -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 , "'" )
test/test-skylighting.hs view
@@ -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