module Text.Highlighting.Kate.Syntax.Xharbour ( 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 = "xHarbour"
syntaxExtensions :: String
syntaxExtensions = "*.prg;*.PRG;*.ch"
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 = "xHarbour" }
context <- currentContext <|> (pushContext "TopLevel" >> 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 [("xHarbour",["TopLevel"])], synStLanguage = "xHarbour", synStCurrentLine = "", synStCharsParsedInLine = 0, synStPrevChar = '\n', synStCaseSensitive = True, synStKeywordCaseSensitive = False, synStCaptures = []}
parseSourceLine = manyTill parseExpressionInternal pEndLine
pEndLine = do
lookAhead $ newline <|> (eof >> return '\n')
context <- currentContext
case context of
"TopLevel" -> return () >> pHandleEndLine
"comment" -> (popContext) >> pEndLine
"ml_comment" -> return () >> pHandleEndLine
"string" -> (popContext) >> pEndLine
"stringc" -> (popContext) >> pEndLine
"logic" -> (popContext) >> pEndLine
"ClassContext" -> return () >> pHandleEndLine
_ -> pHandleEndLine
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"),("Comment","co"),("Operator","bn"),("Number","dv"),("Function","fu"),("String","st"),("Preprocessor","ot")]
parseExpressionInternal = do
context <- currentContext
parseRules context <|> (pDefault >>= withAttribute (fromMaybe "" $ lookup context defaultAttributes))
list_keywords = Set.fromList $ words $ "local global extern field each as set clear screen databases all close color date else elseif in to do loop catch exit box say case switch self super say get read use select otherwise index alias like has return static on off nil ? class external"
list_context'5fbeginners = Set.fromList $ words $ "for if switch while try begin procedure function method"
list_context'5fterminators = Set.fromList $ words $ "next end endif enddo endcase"
list_class'5fkeywords = Set.fromList $ words $ "data inline method classdata init from hidden"
list_set'5fcommands = Set.fromList $ words $ "invalid exact fixed decimals dateformat epoch path default exclusive softseek unique deleted cancel debug typeahead color cursor console alternate altfile device extra extrafile printer printfile margin bell confirm escape insert exit intensity scoreboard delimiters delimchars wrap message mcenter scrollbreak eventmask videomode mblocksize mfileext strictread optimize autopen autorder autoshare language idlerepeat trace tracefile tracestack filecase dircase dirseparator"
list_functions = Set.fromList $ words $ "aadd adel achoice aclone aeval ains ascan asize adir afill atail asort array tassociativearray bin21 bin2l bin2u bin2w i2bin l2bin u2bin w2bin eval fieldblock fieldwblock inkey lastkey mcol mrow nextkey empty word descend __dbdelim __dbsdf os __run alert browse dbedit outerr outstd readkey readvar __atprompt __input __menuto __nonoallert __typefile __xrestscreen __xsavescreen dbappend dbclearfilter dbcloseall dbclosearea dbcommit dbcommitall dbcreate dbdelete dbeval dbf dbfilter dbgobottom dbgoto dbgotop dbrecall dbrlock dbrlocklist dbrunlock dbseek dbselectarea dbsetdriver dbsetfilter dbskip dbstruct dbunlock dbunlockall dbusearea indexext indexkey indexord ordbagext ordbagname ordcondset ordcreate orddestroy ordfor ordkey ordlistadd ordlistclear ordlistrebuild ordname ordnumber ordsetfocus rddlist rddname rddsetdefault __dbcontinue __dbzap __fledit __rddsetdefault __dbcopystruct __dbcopyxstruct __dbcreate __dbstructfilter dbskipper cdow cmonth ctod date day days dow dtoc dtos month year getenv set setmode settypeahead version __setcentury __setfunction break errorsys throw errornew hb_setkeysave hb_setkeycheck hb_setkeyget setkey __quit __wait file frename __dir col maxcol maxrow row hb_colorindex curdir dirchange dirremove diskspace fclose fcreate ferase ferror fopen fread freadstr fseek fwrite hb_diskspace hb_feof isdisk makedir abs exp int log max min mod round sqrt hb_isbyref procfile procline procname type valtype valtoprg tone hb_langname hb_langselect isaffirm isnegative nationmsg pcount hb_pvalue alltrim asc at chr hardcr hb_ansitooem hb_oemtoansi hb_valtostr isalpha isdigit islower isupper left len lower ltrim memotran padc padl padr rat replicate right rtrim space str strtran strzero substr transform trim upper val devoutpict elaptime seconds secs time do threadstart threadstop threadsleep threadkill threadjoin createmutex destroymutex mutexlock mutexunlock subscribe subscribenow notify notifyall waitforthreads killallthreads inetinit inetcleanup inetcreate inetdestroy inetconnect inetserver inetaccept inetsettimeout inetgettimeout inetcleartimeout inetrecv inetrecvall inetsend inetsendall inetdgram inetdgramrecv inetdgramsend inetaddress inetport ineterror ineterrordesc inetgethosts inetconnectip hb_regex hb_regexmatch hb_regexsplit hb_regexcomp hb_readini hb_writeini hb_random hb_chechsum hb_crypt hb_decrypt hb_hextonum hb_numtohex hb_exec hb_execfromarray hb_class hb_keyput hb_osnewline"
list_pragma = Set.fromList $ words $ "#include #if #ifdef #ifndef #endif #else #define"
regex_CLASS'5b'5ct_'5d'2b = compileRegex "CLASS[\\t ]+"
regex_DO'5b'5ct_'5d'2bCASE'5b'5ct_'5d'2a'24 = compileRegex "DO[\\t ]+CASE[\\t ]*$"
regex_return_'3f = compileRegex "return ?"
regex_'5cd'2b = compileRegex "\\d+"
regex_END'28CLASS'29'3f_'2a'24 = compileRegex "END(CLASS)? *$"
defaultAttributes = [("TopLevel","Normal Text"),("comment","Comment"),("ml_comment","Comment"),("string","String"),("stringc","String"),("logic","Operator"),("ClassContext","Normal Text")]
parseRules "TopLevel" =
do (attr, result) <- (((pDetect2Chars False '/' '*' >>= withAttribute "Comment") >>~ pushContext "ml_comment")
<|>
((pFirstNonSpace >> pDetectChar False '*' >>= withAttribute "Comment") >>~ pushContext "comment")
<|>
((pDetect2Chars False '/' '/' >>= withAttribute "Comment") >>~ pushContext "comment")
<|>
((pDetectChar False '"' >>= withAttribute "String") >>~ pushContext "string")
<|>
((pDetectChar False '\'' >>= withAttribute "String") >>~ pushContext "stringc")
<|>
((pString False ".and." >>= withAttribute "Operator"))
<|>
((pString False ".or." >>= withAttribute "Operator"))
<|>
((pString False ".not." >>= withAttribute "Operator"))
<|>
((pString False ".f." >>= withAttribute "Operator"))
<|>
((pString False ".t." >>= withAttribute "Operator"))
<|>
((pAnyChar ":=!" >>= withAttribute "Operator"))
<|>
((pDetectChar False '@' >>= withAttribute "Keyword"))
<|>
((pFirstNonSpace >> pRegExpr regex_CLASS'5b'5ct_'5d'2b >>= withAttribute "Keyword") >>~ pushContext "ClassContext")
<|>
((pFirstNonSpace >> pRegExpr regex_DO'5b'5ct_'5d'2bCASE'5b'5ct_'5d'2a'24 >>= withAttribute "Keyword"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" list_context'5fbeginners >>= withAttribute "Keyword"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" list_context'5fterminators >>= withAttribute "Keyword"))
<|>
((pColumn 0 >> pRegExpr regex_return_'3f >>= withAttribute "Keyword"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" list_keywords >>= withAttribute "Keyword"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" list_set'5fcommands >>= withAttribute "Keyword"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" list_functions >>= withAttribute "Function"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" list_pragma >>= withAttribute "Preprocessor"))
<|>
((pDetect2Chars False '-' '>' >>= withAttribute "Operator"))
<|>
((pRegExpr regex_'5cd'2b >>= withAttribute "Number")))
return (attr, result)
parseRules "comment" =
pzero
parseRules "ml_comment" =
do (attr, result) <- ((pDetect2Chars False '*' '/' >>= withAttribute "Comment") >>~ (popContext))
return (attr, result)
parseRules "string" =
do (attr, result) <- ((pDetectChar False '"' >>= withAttribute "String") >>~ (popContext))
return (attr, result)
parseRules "stringc" =
do (attr, result) <- ((pDetectChar False '\'' >>= withAttribute "String") >>~ (popContext))
return (attr, result)
parseRules "logic" =
do (attr, result) <- ((pDetectChar False '.' >>= withAttribute "Operator") >>~ (popContext))
return (attr, result)
parseRules "ClassContext" =
do (attr, result) <- (((pDetect2Chars False '/' '*' >>= withAttribute "Comment") >>~ pushContext "ml_comment")
<|>
((pFirstNonSpace >> pDetectChar False '*' >>= withAttribute "Comment") >>~ pushContext "comment")
<|>
((pDetect2Chars False '/' '/' >>= withAttribute "Comment") >>~ pushContext "comment")
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" list_class'5fkeywords >>= withAttribute "Keyword"))
<|>
((pFirstNonSpace >> pRegExpr regex_END'28CLASS'29'3f_'2a'24 >>= withAttribute "Keyword") >>~ (popContext)))
return (attr, result)
parseRules x = fail $ "Unknown context" ++ x