module Text.Highlighting.Kate.Syntax.Commonlisp ( highlight, parseExpression, syntaxName, syntaxExtensions ) where
import Text.Highlighting.Kate.Definitions
import Text.Highlighting.Kate.Common
import Text.ParserCombinators.Parsec
import Control.Monad (when)
import Data.Map (fromList)
import Data.Maybe (fromMaybe, maybeToList)
import qualified Data.Set as Set
syntaxName :: String
syntaxName = "Common Lisp"
syntaxExtensions :: String
syntaxExtensions = "*.lisp;*.cl;*.lsp"
highlight :: String -> Either String [SourceLine]
highlight input =
case runParser parseSource startingState "source" input of
Left err -> Left $ show err
Right result -> Right result
parseExpression :: GenParser Char SyntaxState LabeledSource
parseExpression = do
st <- getState
let oldLang = synStLanguage st
setState $ st { synStLanguage = "Common Lisp" }
context <- currentContext <|> (pushContext "Normal" >> currentContext)
result <- parseRules context
updateState $ \st -> st { synStLanguage = oldLang }
return result
parseSource = do
lineContents <- lookAhead wholeLine
updateState $ \st -> st { synStCurrentLine = lineContents }
result <- manyTill parseSourceLine eof
return $ map normalizeHighlighting result
startingState = SyntaxState {synStContexts = fromList [("Common Lisp",["Normal"])], synStLanguage = "Common Lisp", synStCurrentLine = "", synStCharsParsedInLine = 0, synStPrevChar = '\n', synStCaseSensitive = True, synStKeywordCaseSensitive = True, synStCaptures = []}
parseSourceLine = manyTill parseExpressionInternal pEndLine
pEndLine = do
newline <|> (eof >> return '\n')
context <- currentContext
case context of
"Normal" -> return ()
"MultiLineComment" -> return ()
"function_decl" -> return ()
"SpecialNumber" -> (popContext >> return ())
"String" -> return ()
_ -> return ()
lineContents <- lookAhead wholeLine
updateState $ \st -> st { synStCurrentLine = lineContents, synStCharsParsedInLine = 0, synStPrevChar = '\n' }
withAttribute attr txt = do
when (null txt) $ fail "Parser matched no text"
let labs = attr : maybeToList (lookup attr styles)
st <- getState
let oldCharsParsed = synStCharsParsedInLine st
let prevchar = if null txt then '\n' else last txt
updateState $ \st -> st { synStCharsParsedInLine = oldCharsParsed + length txt, synStPrevChar = prevchar }
return (labs, txt)
styles = [("Keyword","kw"),("Operator","kw"),("Modifier","kw"),("Variable","kw"),("Definition","kw"),("Data","dt"),("Decimal","dv"),("BaseN","bn"),("Float","fl"),("Function","fu"),("Char","ch"),("String","st"),("Comment","co"),("Region Marker","re")]
parseExpressionInternal = do
context <- currentContext
parseRules context <|> (pDefault >>= withAttribute (fromMaybe "" $ lookup context defaultAttributes))
list_symbols = Set.fromList $ words $ "< <= = > >= => - / /= // /// * ** *** + ++ +++ 1- 1+"
list_definitions = Set.fromList $ words $ "defclass defconstant defgeneric define-compiler-macro define-condition define-method-combination define-modify-macro define-setf-expander define-setf-method define-symbol-macro defmacro defmethod defpackage defparameter defsetf deftype defvar defun defstruct"
list_keywords = Set.fromList $ words $ "abort abs access acons acos acosh add-method adjoin adjustable-array-p adjust-array allocate-instance alpha-char-p alphanumericp and append apply applyhook apropos apropos-list aref arithmetic-error arithmetic-error-operands arithmetic-error-operation array array-dimension array-dimension-limit array-dimensions array-displacement array-element-type array-has-fill-pointer-p array-in-bounds-p arrayp array-rank array-rank-limit array-row-major-index array-total-size array-total-size-limit ash asin asinh assert assoc assoc-if assoc-if-not atan atanh atom base-char base-string bignum bit bit-and bit-andc1 bit-andc2 bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 bit-orc2 bit-vector bit-vector-p bit-xor block boole boole-1 boole-2 boolean boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor both-case-p boundp break broadcast-stream broadcast-stream-streams built-in-class butlast byte byte-position byte-size call-arguments-limit call-method call-next-method capitalize car case catch ccase cdr ceiling cell-error cell-error-name cerror change-class char char< char<= char= char> char>= char/= character characterp char-bit char-bits char-bits-limit char-code char-code-limit char-control-bit char-downcase char-equal char-font char-font-limit char-greaterp char-hyper-bit char-int char-lessp char-meta-bit char-name char-not-equal char-not-greaterp char-not-lessp char-super-bit char-upcase check-type cis class class-name class-of clear-input clear-output close clrhash code-char coerce commonp compilation-speed compile compiled-function compiled-function-p compile-file compile-file-pathname compiler-let compiler-macro compiler-macro-function complement complex complexp compute-applicable-methods compute-restarts concatenate concatenated-stream concatenated-stream-streams cond condition conjugate cons consp constantly constantp continue control-error copy-alist copy-list copy-pprint-dispatch copy-readtable copy-seq copy-structure copy-symbol copy-tree cos cosh count count-if count-if-not ctypecase debug decf declaim declaration declare decode-float decode-universal-time delete delete-duplicates delete-file delete-if delete-if-not delete-package denominator deposit-field describe describe-object destructuring-bind digit-char digit-char-p directory directory-namestring disassemble division-by-zero do do* do-all-symbols documentation do-exeternal-symbols do-external-symbols dolist do-symbols dotimes double-float double-float-epsilon double-float-negative-epsilon dpb dribble dynamic-extent ecase echo-stream echo-stream-input-stream echo-stream-output-stream ed eighth elt encode-universal-time end-of-file endp enough-namestring ensure-directories-exist ensure-generic-function eq eql equal equalp error etypecase eval evalhook eval-when evenp every exp export expt extended-char fboundp fceiling fdefinition ffloor fifth file-author file-error file-error-pathname file-length file-namestring file-position file-stream file-string-length file-write-date fill fill-pointer find find-all-symbols find-class find-if find-if-not find-method find-package find-restart find-symbol finish-output first fixnum flet float float-digits floating-point-inexact floating-point-invalid-operation floating-point-overflow floating-point-underflow floatp float-precision float-radix float-sign floor fmakunbound force-output format formatter fourth fresh-line fround ftruncate ftype funcall function function-keywords function-lambda-expression functionp gbitp gcd generic-function gensym gentemp get get-decoded-time get-dispatch-macro-character getf gethash get-internal-real-time get-internal-run-time get-macro-character get-output-stream-string get-properties get-setf-expansion get-setf-method get-universal-time go graphic-char-p handler-bind handler-case hash-table hash-table-count hash-table-p hash-table-rehash-size hash-table-rehash-threshold hash-table-size hash-table-test host-namestring identity if if-exists ignorable ignore ignore-errors imagpart import incf initialize-instance inline in-package in-package input-stream-p inspect int-char integer integer-decode-float integer-length integerp interactive-stream-p intern internal-time-units-per-second intersection invalid-method-error invoke-debugger invoke-restart invoke-restart-interactively isqrt keyword keywordp labels lambda lambda-list-keywords lambda-parameters-limit last lcm ldb ldb-test ldiff least-negative-double-float least-negative-long-float least-negative-normalized-double-float least-negative-normalized-long-float least-negative-normalized-short-float least-negative-normalized-single-float least-negative-short-float least-negative-single-float least-positive-double-float least-positive-long-float least-positive-normalized-double-float least-positive-normalized-long-float least-positive-normalized-short-float least-positive-normalized-single-float least-positive-short-float least-positive-single-float length let let* lisp lisp-implementation-type lisp-implementation-version list list* list-all-packages listen list-length listp load load-logical-pathname-translations load-time-value locally log logand logandc1 logandc2 logbitp logcount logeqv logical-pathname logical-pathname-translations logior lognand lognor lognot logorc1 logorc2 logtest logxor long-float long-float-epsilon long-float-negative-epsilon long-site-name loop loop-finish lower-case-p machine-instance machine-type machine-version macroexpand macroexpand-1 macroexpand-l macro-function macrolet make-array make-array make-broadcast-stream make-char make-concatenated-stream make-condition make-dispatch-macro-character make-echo-stream make-hash-table make-instance make-instances-obsolete make-list make-load-form make-load-form-saving-slots make-method make-package make-pathname make-random-state make-sequence make-string make-string-input-stream make-string-output-stream make-symbol make-synonym-stream make-two-way-stream makunbound map mapc mapcan mapcar mapcon maphash map-into mapl maplist mask-field max member member-if member-if-not merge merge-pathname merge-pathnames method method-combination method-combination-error method-qualifiers min minusp mismatch mod most-negative-double-float most-negative-fixnum most-negative-long-float most-negative-short-float most-negative-single-float most-positive-double-float most-positive-fixnum most-positive-long-float most-positive-short-float most-positive-single-float muffle-warning multiple-value-bind multiple-value-call multiple-value-list multiple-value-prog1 multiple-value-seteq multiple-value-setq multiple-values-limit name-char namestring nbutlast nconc next-method-p nil nintersection ninth no-applicable-method no-next-method not notany notevery notinline nreconc nreverse nset-difference nset-exclusive-or nstring nstring-capitalize nstring-downcase nstring-upcase nsublis nsubst nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not nth nthcdr nth-value null number numberp numerator nunion oddp open open-stream-p optimize or otherwise output-stream-p package package-error package-error-package package-name package-nicknames packagep package-shadowing-symbols package-used-by-list package-use-list pairlis parse-error parse-integer parse-namestring pathname pathname-device pathname-directory pathname-host pathname-match-p pathname-name pathnamep pathname-type pathname-version peek-char phase pi plusp pop position position-if position-if-not pprint pprint-dispatch pprint-exit-if-list-exhausted pprint-fill pprint-indent pprint-linear pprint-logical-block pprint-newline pprint-pop pprint-tab pprint-tabular prin1 prin1-to-string princ princ-to-string print print-not-readable print-not-readable-object print-object print-unreadable-object probe-file proclaim prog prog* prog1 prog2 progn program-error progv provide psetf psetq push pushnew putprop quote random random-state random-state-p rassoc rassoc-if rassoc-if-not ratio rational rationalize rationalp read read-byte read-char read-char-no-hang read-delimited-list reader-error read-eval-print read-from-string read-line read-preserving-whitespace read-sequence readtable readtable-case readtablep real realp realpart reduce reinitialize-instance rem remf remhash remove remove-duplicates remove-if remove-if-not remove-method remprop rename-file rename-package replace require rest restart restart-bind restart-case restart-name return return-from revappend reverse room rotatef round row-major-aref rplaca rplacd safety satisfies sbit scale-float schar search second sequence serious-condition set set-char-bit set-difference set-dispatch-macro-character set-exclusive-or setf set-macro-character set-pprint-dispatch setq set-syntax-from-char seventh shadow shadowing-import shared-initialize shiftf short-float short-float-epsilon short-float-negative-epsilon short-site-name signal signed-byte signum simle-condition simple-array simple-base-string simple-bit-vector simple-bit-vector-p simple-condition-format-arguments simple-condition-format-control simple-error simple-string simple-string-p simple-type-error simple-vector simple-vector-p simple-warning sin single-flaot-epsilon single-float single-float-epsilon single-float-negative-epsilon sinh sixth sleep slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound slot-value software-type software-version some sort space special special-form-p special-operator-p speed sqrt stable-sort standard standard-char standard-char-p standard-class standard-generic-function standard-method standard-object step storage-condition store-value stream stream-element-type stream-error stream-error-stream stream-external-format streamp streamup string string< string<= string= string> string>= string/= string-capitalize string-char string-char-p string-downcase string-equal string-greaterp string-left-trim string-lessp string-not-equal string-not-greaterp string-not-lessp stringp string-right-strim string-right-trim string-stream string-trim string-upcase structure structure-class structure-object style-warning sublim sublis subseq subsetp subst subst-if subst-if-not substitute substitute-if substitute-if-not subtypep svref sxhash symbol symbol-function symbol-macrolet symbol-name symbolp symbol-package symbol-plist symbol-value synonym-stream synonym-stream-symbol sys system t tagbody tailp tan tanh tenth terpri the third throw time trace translate-logical-pathname translate-pathname tree-equal truename truncase truncate two-way-stream two-way-stream-input-stream two-way-stream-output-stream type typecase type-error type-error-datum type-error-expected-type type-of typep unbound-slot unbound-slot-instance unbound-variable undefined-function unexport unintern union unless unread unread-char unsigned-byte untrace unuse-package unwind-protect update-instance-for-different-class update-instance-for-redefined-class upgraded-array-element-type upgraded-complex-part-type upper-case-p use-package user user-homedir-pathname use-value values values-list vector vectorp vector-pop vector-push vector-push-extend warn warning when wild-pathname-p with-accessors with-compilation-unit with-condition-restarts with-hash-table-iterator with-input-from-string with-open-file with-open-stream with-output-to-string with-package-iterator with-simple-restart with-slots with-standard-io-syntax write write-byte write-char write-line write-sequence write-string write-to-string yes-or-no-p y-or-n-p zerop"
list_modifiers = Set.fromList $ words $ ":abort :adjustable :append :array :base :case :circle :conc-name :constructor :copier :count :create :default :defaults :device :direction :directory :displaced-index-offset :displaced-to :element-type :end1 :end2 :end :error :escape :external :from-end :gensym :host :if-does-not-exist:pretty :if-exists:print :include:print-function :index :inherited :initial-contents :initial-element :initial-offset :initial-value :input :internal:size :io :junk-allowed :key :length :level :named :name :new-version :nicknames :output-file :output :overwrite :predicate :preserve-whitespace :probe :radix :read-only :rehash-size :rehash-threshold :rename-and-delete :rename :start1 :start2 :start :stream :supersede :test :test-not :type :use :verbose :version"
list_variables = Set.fromList $ words $ "*applyhook* *break-on-signals* *break-on-signals* *break-on-warnings* *compile-file-pathname* *compile-file-pathname* *compile-file-truename* *compile-file-truename* *compile-print* *compile-verbose* *compile-verbose* *debugger-hook* *debug-io* *default-pathname-defaults* *error-output* *evalhook* *features* *gensym-counter* *load-pathname* *load-print* *load-truename* *load-verbose* *macroexpand-hook* *modules* *package* *print-array* *print-base* *print-case* *print-circle* *print-escape* *print-gensym* *print-length* *print-level* *print-lines* *print-miser-width* *print-miser-width* *print-pprint-dispatch* *print-pprint-dispatch* *print-pretty* *print-radix* *print-readably* *print-right-margin* *print-right-margin* *query-io* *random-state* *read-base* *read-default-float-format* *read-eval* *read-suppress* *readtable* *standard-input* *standard-output* *terminal-io* *trace-output*"
regex_'3b'2b'5cs'2aBEGIN'2e'2a'24 = compileRegex ";+\\s*BEGIN.*$"
regex_'3b'2b'5cs'2aEND'2e'2a'24 = compileRegex ";+\\s*END.*$"
regex_'3b'2e'2a'24 = compileRegex ";.*$"
regex_'23'5c'5c'2e = compileRegex "#\\\\."
regex_'23'5bbodxei'5d = compileRegex "#[bodxei]"
regex_'23'5btf'5d = compileRegex "#[tf]"
regex_'5cs'2a'5bA'2dZa'2dz0'2d9'2d'2b'5c'3c'5c'3e'2f'2f'5c'2a'5d'2a'5cs'2a = compileRegex "\\s*[A-Za-z0-9-+\\<\\>//\\*]*\\s*"
defaultAttributes = [("Normal","Normal"),("MultiLineComment","Comment"),("function_decl","Function"),("SpecialNumber","Normal"),("String","String")]
parseRules "Normal" =
do (attr, result) <- (((pRegExpr regex_'3b'2b'5cs'2aBEGIN'2e'2a'24 >>= withAttribute "Region Marker"))
<|>
((pRegExpr regex_'3b'2b'5cs'2aEND'2e'2a'24 >>= withAttribute "Region Marker"))
<|>
((pRegExpr regex_'3b'2e'2a'24 >>= withAttribute "Comment"))
<|>
((pDetect2Chars False '#' '|' >>= withAttribute "Comment") >>~ pushContext "MultiLineComment")
<|>
((pDetectChar False '(' >>= withAttribute "Brackets"))
<|>
((pDetectChar False ')' >>= withAttribute "Brackets"))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_keywords >>= withAttribute "Keyword"))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_symbols >>= withAttribute "Operator"))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_modifiers >>= withAttribute "Modifier"))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_variables >>= withAttribute "Variable"))
<|>
((pKeyword " \n\t.(),%&;[]^{|}~" list_definitions >>= withAttribute "Definition") >>~ pushContext "function_decl")
<|>
((pRegExpr regex_'23'5c'5c'2e >>= withAttribute "Char"))
<|>
((pDetectChar False '"' >>= withAttribute "String") >>~ pushContext "String")
<|>
((pRegExpr regex_'23'5bbodxei'5d >>= withAttribute "Char") >>~ pushContext "SpecialNumber")
<|>
((pRegExpr regex_'23'5btf'5d >>= withAttribute "Decimal"))
<|>
((pFloat >>= withAttribute "Float"))
<|>
((pInt >>= withAttribute "Decimal")))
return (attr, result)
parseRules "MultiLineComment" =
do (attr, result) <- ((pDetect2Chars False '|' '#' >>= withAttribute "Comment") >>~ (popContext >> return ()))
return (attr, result)
parseRules "function_decl" =
do (attr, result) <- ((pRegExpr regex_'5cs'2a'5bA'2dZa'2dz0'2d9'2d'2b'5c'3c'5c'3e'2f'2f'5c'2a'5d'2a'5cs'2a >>= withAttribute "Function") >>~ (popContext >> return ()))
return (attr, result)
parseRules "SpecialNumber" =
do (attr, result) <- (((pFloat >>= withAttribute "Float") >>~ (popContext >> return ()))
<|>
((pInt >>= withAttribute "Decimal") >>~ (popContext >> return ()))
<|>
((pHlCOct >>= withAttribute "BaseN") >>~ (popContext >> return ()))
<|>
((pHlCHex >>= withAttribute "Float") >>~ (popContext >> return ())))
return (attr, result)
parseRules "String" =
do (attr, result) <- (((pRegExpr regex_'23'5c'5c'2e >>= withAttribute "Char"))
<|>
((pDetectChar False '"' >>= withAttribute "String") >>~ (popContext >> return ())))
return (attr, result)
parseRules x = fail $ "Unknown context" ++ x