module Text.Highlighting.Kate.Syntax.Scheme
(highlight, parseExpression, syntaxName, syntaxExtensions)
where
import Text.Highlighting.Kate.Types
import Text.Highlighting.Kate.Common
import Text.ParserCombinators.Parsec hiding (State)
import Control.Monad.State
import Data.Char (isSpace)
import qualified Data.Set as Set
syntaxName :: String
syntaxName = "Scheme"
syntaxExtensions :: String
syntaxExtensions = "*.scm;*.ss;*.scheme;*.guile"
highlight :: String -> [SourceLine]
highlight input = evalState (mapM parseSourceLine $ lines input) startingState
parseSourceLine :: String -> State SyntaxState SourceLine
parseSourceLine = mkParseSourceLine (parseExpression Nothing)
parseExpression :: Maybe (String,String)
-> KateParser Token
parseExpression mbcontext = do
(lang,cont) <- maybe currentContext return mbcontext
result <- parseRules (lang,cont)
optional $ do eof
updateState $ \st -> st{ synStPrevChar = '\n' }
pEndLine
return result
startingState = SyntaxState {synStContexts = [("Scheme","Level0")], synStLineNumber = 0, synStPrevChar = '\n', synStPrevNonspace = False, synStContinuation = False, synStCaseSensitive = True, synStKeywordCaseSensitive = True, synStCaptures = []}
pEndLine = do
updateState $ \st -> st{ synStPrevNonspace = False }
context <- currentContext
contexts <- synStContexts `fmap` getState
st <- getState
if length contexts >= 2
then case context of
_ | synStContinuation st -> updateState $ \st -> st{ synStContinuation = False }
("Scheme","Level0") -> return ()
("Scheme","Default") -> return ()
("Scheme","MultiLineComment") -> return ()
("Scheme","SpecialNumber") -> (popContext) >> pEndLine
("Scheme","String") -> return ()
("Scheme","function_decl") -> return ()
("Scheme","Level1") -> return ()
("Scheme","Level2") -> return ()
("Scheme","Level3") -> return ()
("Scheme","Level4") -> return ()
("Scheme","Level5") -> return ()
("Scheme","Level6") -> return ()
_ -> return ()
else return ()
withAttribute attr txt = do
when (null txt) $ fail "Parser matched no text"
updateState $ \st -> st { synStPrevChar = last txt
, synStPrevNonspace = synStPrevNonspace st || not (all isSpace txt) }
return (attr, txt)
list_operators = Set.fromList $ words $ "<= < = => >= > - / *,* *) +"
list_characters = Set.fromList $ words $ "#\\nul #\\soh #\\stx #\\etx #\\eot #\\enq #\\ack #\\bel #\\bs #\\ht #\\nl #\\vt #\\np #\\cr #\\so #\\si #\\dle #\\dc1 #\\dc2 #\\dc3 #\\dc4 #\\nak #\\syn #\\etb #\\can #\\em #\\sub #\\esc #\\fs #\\gs #\\rs #\\us #\\space #\\sp #\\newline #\\nl #\\tab #\\ht #\\backspace #\\bs #\\return #\\cr #\\page #\\np #\\null #\\nul"
list_defines = Set.fromList $ words $ "define define* define-accessor define-class defined? define-generic define-macro define-method define-module define-private define-public define*-public define-reader-ctor define-syntax define-syntax-macro defmacro defmacro* defmacro*-public"
list_keywords = Set.fromList $ words $ "abs acos and angle append applymap asin assoc assq assv atan begin boolean? break caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call/cc call-with-current-continuation call-with-input-file call-with-output-file call-with-values car case catch cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char-alphabetic? char-ci>=? char-ci>? char-ci=? char-ci<=? char-downcase char->integer char>=? char>? char=? char? char-lower-case? char<?c char<=? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? close-input-port close-output-port complex? cond cons continue cos current-input-port current-output-port denominator display do dynamic-wind else eof-object? eq? equal? eqv? eval even? exact->inexact exact? exp expt floor force for-each gcd har-ci<? if imag-part inexact->exact inexact? input-port? integer->char integer? interaction-environment lambda lcm length let let* letrec letrec-syntax let-syntax list->string list list? list-ref list-tail load log magnitude make-polar make-rectangular make-string make-vector max member memq memv min modulo negative? newline not null-environment null? number? number->string numerator odd? open-input-file open-output-file or output-port? pair? peek-char port? positive? procedure? quotient rational? rationalize read-char read real? real-part remainder reverse round scheme-report-environment set-car! set-cdr! sin sqrt string-append string-ci>=? string-ci>? string-ci=? string-ci<=? string-ci<? string-copy string-fill! string>=? string>? string->list string->number string->symbol string=? string string? string-length string<=? string<? string-ref string-set! substring symbol->string symbol? syntax-rules tan transcript-off transcript-on truncate values vector-fill! vector->listlist->vector vector vector? vector-length vector-ref vector-set! while with-input-from-file with-output-to-file write-char write zero?"
regex_'3b'2b'5cs'2aBEGIN'2e'2a'24 = compileRegex True ";+\\s*BEGIN.*$"
regex_'3b'2b'5cs'2aEND'2e'2a'24 = compileRegex True ";+\\s*END.*$"
regex_'3b'2e'2a'24 = compileRegex True ";.*$"
regex_'23'5c'5c'2e = compileRegex True "#\\\\."
regex_'23'5bbodxei'5d = compileRegex True "#[bodxei]"
regex_'23'5btf'5d = compileRegex True "#[tf]"
regex_'21'23'5cs'2a'24 = compileRegex True "!#\\s*$"
regex_'5cd'2a'28'5c'2e'5cd'2b'29'3f = compileRegex True "\\d*(\\.\\d+)?"
regex_'5cs'2a'5bA'2dZa'2dz0'2d9'2d'2b'5c'3c'5c'3e'2f'2f'5c'2a'5d'2a'5cs'2a = compileRegex True "\\s*[A-Za-z0-9-+\\<\\>//\\*]*\\s*"
parseRules ("Scheme","Level0") =
(((pDetectChar False '(' >>= withAttribute NormalTok) >>~ pushContext ("Scheme","Level1"))
<|>
((parseRules ("Scheme","Default")))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","Level0")) >> pDefault >>= withAttribute NormalTok))
parseRules ("Scheme","Default") =
(((pRegExpr regex_'3b'2b'5cs'2aBEGIN'2e'2a'24 >>= withAttribute RegionMarkerTok))
<|>
((pRegExpr regex_'3b'2b'5cs'2aEND'2e'2a'24 >>= withAttribute RegionMarkerTok))
<|>
((pRegExpr regex_'3b'2e'2a'24 >>= withAttribute CommentTok))
<|>
((pDetect2Chars False '#' '!' >>= withAttribute CommentTok) >>~ pushContext ("Scheme","MultiLineComment"))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_keywords >>= withAttribute KeywordTok))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_operators >>= withAttribute KeywordTok))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_defines >>= withAttribute KeywordTok) >>~ pushContext ("Scheme","function_decl"))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_characters >>= withAttribute CharTok))
<|>
((pRegExpr regex_'23'5c'5c'2e >>= withAttribute CharTok))
<|>
((pDetectChar False '"' >>= withAttribute StringTok) >>~ pushContext ("Scheme","String"))
<|>
((pRegExpr regex_'23'5bbodxei'5d >>= withAttribute CharTok) >>~ pushContext ("Scheme","SpecialNumber"))
<|>
((pRegExpr regex_'23'5btf'5d >>= withAttribute DecValTok))
<|>
((pFloat >>= withAttribute FloatTok))
<|>
((pInt >>= withAttribute DecValTok))
<|>
((pDetectChar False '(' >>= withAttribute NormalTok) >>~ pushContext ("Scheme","Level1"))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","Default")) >> pDefault >>= withAttribute NormalTok))
parseRules ("Scheme","MultiLineComment") =
(((pColumn 0 >> pRegExpr regex_'21'23'5cs'2a'24 >>= withAttribute CommentTok) >>~ (popContext))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","MultiLineComment")) >> pDefault >>= withAttribute CommentTok))
parseRules ("Scheme","SpecialNumber") =
(((pRegExpr regex_'5cd'2a'28'5c'2e'5cd'2b'29'3f >>= withAttribute DecValTok) >>~ (popContext))
<|>
((popContext) >> currentContext >>= parseRules))
parseRules ("Scheme","String") =
(((pKeyword " \n\t.(),%&;[]^{|}~" list_characters >>= withAttribute CharTok))
<|>
((pRegExpr regex_'23'5c'5c'2e >>= withAttribute CharTok))
<|>
((pDetect2Chars False '\\' '"' >>= withAttribute CharTok))
<|>
((pDetect2Chars False '\\' '\\' >>= withAttribute CharTok))
<|>
((pDetectChar False '"' >>= withAttribute StringTok) >>~ (popContext))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","String")) >> pDefault >>= withAttribute StringTok))
parseRules ("Scheme","function_decl") =
(((pRegExpr regex_'5cs'2a'5bA'2dZa'2dz0'2d9'2d'2b'5c'3c'5c'3e'2f'2f'5c'2a'5d'2a'5cs'2a >>= withAttribute FunctionTok) >>~ (popContext))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","function_decl")) >> pDefault >>= withAttribute FunctionTok))
parseRules ("Scheme","Level1") =
(((pDetectChar False '(' >>= withAttribute NormalTok) >>~ pushContext ("Scheme","Level2"))
<|>
((pDetectChar False ')' >>= withAttribute NormalTok) >>~ (popContext))
<|>
((parseRules ("Scheme","Default")))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","Level1")) >> pDefault >>= withAttribute NormalTok))
parseRules ("Scheme","Level2") =
(((pDetectChar False '(' >>= withAttribute NormalTok) >>~ pushContext ("Scheme","Level3"))
<|>
((pDetectChar False ')' >>= withAttribute NormalTok) >>~ (popContext))
<|>
((parseRules ("Scheme","Default")))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","Level2")) >> pDefault >>= withAttribute NormalTok))
parseRules ("Scheme","Level3") =
(((pDetectChar False '(' >>= withAttribute NormalTok) >>~ pushContext ("Scheme","Level4"))
<|>
((pDetectChar False ')' >>= withAttribute NormalTok) >>~ (popContext))
<|>
((parseRules ("Scheme","Default")))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","Level3")) >> pDefault >>= withAttribute NormalTok))
parseRules ("Scheme","Level4") =
(((pDetectChar False '(' >>= withAttribute NormalTok) >>~ pushContext ("Scheme","Level5"))
<|>
((pDetectChar False ')' >>= withAttribute NormalTok) >>~ (popContext))
<|>
((parseRules ("Scheme","Default")))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","Level4")) >> pDefault >>= withAttribute NormalTok))
parseRules ("Scheme","Level5") =
(((pDetectChar False '(' >>= withAttribute NormalTok) >>~ pushContext ("Scheme","Level6"))
<|>
((pDetectChar False ')' >>= withAttribute NormalTok) >>~ (popContext))
<|>
((parseRules ("Scheme","Default")))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","Level5")) >> pDefault >>= withAttribute NormalTok))
parseRules ("Scheme","Level6") =
(((pDetectChar False '(' >>= withAttribute NormalTok) >>~ pushContext ("Scheme","Level1"))
<|>
((pDetectChar False ')' >>= withAttribute NormalTok) >>~ (popContext))
<|>
((parseRules ("Scheme","Default")))
<|>
(currentContext >>= \x -> guard (x == ("Scheme","Level6")) >> pDefault >>= withAttribute NormalTok))
parseRules x = parseRules ("Scheme","Level0") <|> fail ("Unknown context" ++ show x)