module Text.Highlighting.Kate.Syntax.Fortran ( highlight, parseExpression, syntaxName, syntaxExtensions ) where
import Text.Highlighting.Kate.Definitions
import Text.Highlighting.Kate.Common
import Text.ParserCombinators.Parsec
import Data.List (nub)
import Data.Map (fromList)
import Data.Maybe (fromMaybe)
syntaxName :: String
syntaxName = "Fortran"
syntaxExtensions :: String
syntaxExtensions = "*.f;*.F;*.for;*.FOR;*.f90;*.F90;*.fpp;*.FPP;*.f95;*.F95;"
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 = "Fortran" }
context <- currentContext <|> (pushContext "default" >> 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 [("Fortran",["default"])], synStLanguage = "Fortran", synStCurrentLine = "", synStCharsParsedInLine = 0, synStCaseSensitive = False, synStKeywordCaseSensitive = False, synStCaptures = []}
parseSourceLine = manyTill parseExpressionInternal pEndLine
pEndLine = do
newline <|> (eof >> return '\n')
context <- currentContext
case context of
"default" -> return ()
"find_preprocessor" -> return ()
"find_op_and_log" -> return ()
"find_comments" -> return ()
"find_symbols" -> return ()
"inside_func_paren" -> return ()
"find_io_stmnts" -> return ()
"find_io_paren" -> return ()
"format_stmnt" -> return ()
"find_begin_stmnts" -> return ()
"find_end_stmnts" -> return ()
"find_decls" -> return ()
"find_paren" -> (popContext >> return ())
"find_intrinsics" -> return ()
"find_numbers" -> return ()
"find_strings" -> return ()
"string_1" -> return ()
"string_2" -> return ()
"end_of_string" -> return ()
_ -> return ()
lineContents <- lookAhead wholeLine
updateState $ \st -> st { synStCurrentLine = lineContents, synStCharsParsedInLine = 0 }
withAttribute attr txt = do
if null txt
then fail "Parser matched no text"
else return ()
let style = fromMaybe "" $ lookup attr styles
st <- getState
let oldCharsParsed = synStCharsParsedInLine st
updateState $ \st -> st { synStCharsParsedInLine = oldCharsParsed + length txt }
return (nub [style, attr], txt)
styles = [("Normal Text","Normal"),("Keyword","Keyword"),("Data Type","DataType"),("Decimal","DecVal"),("Float","Float"),("String","String"),("Comment","Comment"),("Symbol","Normal"),("Preprocessor","Others"),("Operator","Keyword"),("Logical","Others"),("IO Function","Function"),("Elemental Procedure","Keyword"),("Inquiry Function","Function"),("Transformational Function","Function"),("Non elemental subroutine","Keyword")]
parseExpressionInternal = do
context <- currentContext
parseRules context <|> (pDefault >>= withAttribute (fromMaybe "" $ lookup context defaultAttributes))
defaultAttributes = [("default","Normal Text"),("find_preprocessor","Normal Text"),("find_op_and_log","Normal Text"),("find_comments","Normal Text"),("find_symbols","Normal Text"),("inside_func_paren","Normal Text"),("find_io_stmnts","Normal Text"),("find_io_paren","Normal Text"),("format_stmnt","Normal Text"),("find_begin_stmnts","Normal Text"),("find_end_stmnts","Normal Text"),("find_decls","Normal Text"),("find_paren","Data Type"),("find_intrinsics","Normal Text"),("find_numbers","Normal Text"),("find_strings","String"),("string_1","String"),("string_2","String"),("end_of_string","String")]
parseRules "default" =
do (attr, result) <- (((parseRules "find_strings"))
<|>
((parseRules "find_decls"))
<|>
((parseRules "find_intrinsics"))
<|>
((parseRules "find_io_stmnts"))
<|>
((parseRules "find_op_and_log"))
<|>
((parseRules "find_numbers"))
<|>
((parseRules "find_preprocessor"))
<|>
((parseRules "find_comments"))
<|>
((parseRules "find_symbols"))
<|>
((parseRules "find_end_stmnts"))
<|>
((parseRules "find_begin_stmnts")))
return (attr, result)
parseRules "find_preprocessor" =
do (attr, result) <- ((pColumn 0 >> pRegExpr (compileRegex "(#|cDEC\\$|CDEC\\$).*$") >>= withAttribute "Preprocessor"))
return (attr, result)
parseRules "find_op_and_log" =
do (attr, result) <- (((pRegExpr (compileRegex "\\.(true|false)\\.") >>= withAttribute "Logical"))
<|>
((pRegExpr (compileRegex "\\.[A-Za-z]+\\.") >>= withAttribute "Operator"))
<|>
((pRegExpr (compileRegex "(==|/=|<|<=|>|>=)") >>= withAttribute "Operator")))
return (attr, result)
parseRules "find_comments" =
do (attr, result) <- (((pColumn 0 >> pRegExpr (compileRegex "[cC\\*].*$") >>= withAttribute "Comment"))
<|>
((pRegExpr (compileRegex "!.*$") >>= withAttribute "Comment")))
return (attr, result)
parseRules "find_symbols" =
do (attr, result) <- (((pDetect2Chars False '*' '*' >>= withAttribute "Keyword"))
<|>
((pDetect2Chars False '(' '/' >>= withAttribute "Keyword"))
<|>
((pDetect2Chars False '/' ')' >>= withAttribute "Keyword"))
<|>
((pAnyChar "&+-*/=?[]^{|}~" >>= withAttribute "Keyword"))
<|>
((pAnyChar "()," >>= withAttribute "Symbol")))
return (attr, result)
parseRules "inside_func_paren" =
do (attr, result) <- (((pDetectChar False '(' >>= withAttribute "Normal Text") >>~ pushContext "inside_func_paren")
<|>
((pDetectChar False ')' >>= withAttribute "Normal Text") >>~ (popContext >> return ()))
<|>
((parseRules "find_strings"))
<|>
((parseRules "find_intrinsics"))
<|>
((parseRules "find_numbers")))
return (attr, result)
parseRules "find_io_stmnts" =
do (attr, result) <- (((pRegExpr (compileRegex "\\b(read|write|backspace|rewind|end\\s*file|close)\\s*[(]") >>= withAttribute "IO Function") >>~ pushContext "find_io_paren")
<|>
((pRegExpr (compileRegex "\\bopen\\s*[(]") >>= withAttribute "IO Function") >>~ pushContext "find_io_paren")
<|>
((pRegExpr (compileRegex "\\binquire\\s*[(]") >>= withAttribute "IO Function") >>~ pushContext "find_io_paren")
<|>
((pRegExpr (compileRegex "\\bformat\\s*[(]") >>= withAttribute "IO Function") >>~ pushContext "format_stmnt")
<|>
((pRegExpr (compileRegex "\\bend\\s*file\\b") >>= withAttribute "IO Function"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["access","backspace","close","inquire","open","print","read","rewind","write","format"] >>= withAttribute "IO Function")))
return (attr, result)
parseRules "find_io_paren" =
do (attr, result) <- (((pDetectChar False '*' >>= withAttribute "IO Function"))
<|>
((pDetectChar False '(' >>= withAttribute "Normal Text") >>~ pushContext "inside_func_paren")
<|>
((pDetectChar False ')' >>= withAttribute "IO Function") >>~ (popContext >> return ()))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["unit","end","err","fmt","iostat","status","advance","size","eor"] >>= withAttribute "IO Function"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["unit","iostat","err","file","exist","opened","number","named","name","access","sequential","direct","form","formatted","unformatted","recl","nextrec","blank","position","action","read","write","readwrite","delim","pad"] >>= withAttribute "IO Function"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["unit","iostat","err","file","status","access","form","recl","blank","position","action","delim","pad"] >>= withAttribute "IO Function"))
<|>
((parseRules "find_strings"))
<|>
((parseRules "find_intrinsics"))
<|>
((parseRules "find_numbers"))
<|>
((parseRules "find_symbols")))
return (attr, result)
parseRules "format_stmnt" =
do (attr, result) <- (((pDetectChar False '(' >>= withAttribute "IO Function") >>~ pushContext "format_stmnt")
<|>
((pDetectChar False ')' >>= withAttribute "IO Function") >>~ (popContext >> return ()))
<|>
((pRegExpr (compileRegex "[0-9]*/") >>= withAttribute "IO Function"))
<|>
((pAnyChar ":" >>= withAttribute "IO Function"))
<|>
((parseRules "find_strings"))
<|>
((parseRules "find_symbols")))
return (attr, result)
parseRules "find_begin_stmnts" =
do (attr, result) <- (((pRegExpr (compileRegex "\\bmodule\\s+procedure\\b") >>= withAttribute "Keyword"))
<|>
((pRegExpr (compileRegex "\\b(program|subroutine|function|module|block\\s*data)\\b") >>= withAttribute "Keyword")))
return (attr, result)
parseRules "find_end_stmnts" =
do (attr, result) <- (((pRegExpr (compileRegex "\\bend\\s*(program|subroutine|function|module|block\\s*data)\\b") >>= withAttribute "Keyword"))
<|>
((pRegExpr (compileRegex "\\bend\\s*(do|if|select|where|forall|interface)\\b") >>= withAttribute "Keyword"))
<|>
((pRegExpr (compileRegex "\\bend\\b") >>= withAttribute "Keyword")))
return (attr, result)
parseRules "find_decls" =
do (attr, result) <- (((pRegExpr (compileRegex "\\binteger[\\*]\\d{1,2}") >>= withAttribute "Data Type"))
<|>
((pRegExpr (compileRegex "\\breal[\\*]\\d{1,2}") >>= withAttribute "Data Type"))
<|>
((pRegExpr (compileRegex "\\bcomplex[\\*]\\d{1,2}") >>= withAttribute "Data Type"))
<|>
((pRegExpr (compileRegex "\\bend\\s*type\\b") >>= withAttribute "Data Type"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["double","precision","parameter","save","pointer","public","private","target","allocatable","optional","sequence"] >>= withAttribute "Data Type"))
<|>
((pColumn 0 >> pRegExpr (compileRegex "\\s*data\\b") >>= withAttribute "Data Type"))
<|>
((pColumn 0 >> pRegExpr (compileRegex "\\s*real\\s*[(]") >>= withAttribute "Data Type") >>~ pushContext "find_paren")
<|>
((pColumn 0 >> pRegExpr (compileRegex "\\s*real(?![\\w\\*])") >>= withAttribute "Data Type"))
<|>
((pRegExpr (compileRegex "\\bcharacter[*][0-9]+\\b") >>= withAttribute "Data Type"))
<|>
((pRegExpr (compileRegex "\\b(type|integer|complex|character|logical|intent|dimension)\\b\\s*[(]") >>= withAttribute "Data Type") >>~ pushContext "find_paren")
<|>
((pRegExpr (compileRegex "\\b(type|integer|complex|character|logical|intent|dimension)\\b") >>= withAttribute "Data Type"))
<|>
((pDetect2Chars False ':' ':' >>= withAttribute "Data Type")))
return (attr, result)
parseRules "find_paren" =
do (attr, result) <- (((pDetectChar False '(' >>= withAttribute "Data Type") >>~ pushContext "find_paren")
<|>
((pDetectChar False ')' >>= withAttribute "Data Type") >>~ (popContext >> return ())))
return (attr, result)
parseRules "find_intrinsics" =
do (attr, result) <- (((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["allocate","break","call","case","common","contains","continue","cycle","deallocate","default","do","forall","where","elsewhere","elseif","else","equivalence","exit","external","for","go","goto","if","implicit","include","interface","intrinsic","namelist","none","nullify","operator","assignment","pause","procedure","pure","elemental","record","recursive","result","return","select","selectcase","stop","then","to","use","only","entry","while"] >>= withAttribute "Keyword"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["abs","cabs","dabs","iabs","aimag","aint","dint","anint","dnint","ceiling","cmplx","dcmplx","dimag","floor","nint","idnint","int","idint","ifix","real","float","sngl","dble","dreal","aprime","dconjg","dfloat","ddmim","rand","modulo","conjg","dprod","dim","ddim","idim","max","amax0","amax1","max0","max1","dmax1","min","amin0","amin1","min0","min1","dmin1","mod","amod","dmod","sign","dsign","isign","acos","dacos","asin","dasin","atan","datan","atan2","datan2","cos","ccos","dcos","cosh","dcosh","exp","cexp","dexp","log","alog","dlog","clog","log10","alog10","dlog10","sin","csin","dsin","sinh","dsinh","sqrt","csqrt","dsqrt","tan","dtan","tanh","dtanh","achar","char","iachar","ichar","lge","lgt","lle","llt","adjustl","adjustr","index","len_trim","scan","verify","logical","exponent","fraction","nearest","rrspacing","scale","set_exponent","spacing","btest","iand","ibclr","ibits","ibset","ieor","ior","ishft","ishftc","not","mvbits","merge"] >>= withAttribute "Elemental Procedure"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["associated","present","kind","len","digits","epsilon","huge","maxexponent","minexponent","precision","radix","range","tiny","bit_size","allocated","lbound","ubound","shape","size"] >>= withAttribute "Inquiry Function"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["repeat","trim","selected_int_kind","selected_real_kind","transfer","dot_product","matmul","all","any","count","maxval","minval","product","sum","pack","unpack","reshape","spread","cshift","eoshift","transpose","maxloc","minloc"] >>= withAttribute "Transformational Function"))
<|>
((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" ["date_and_time","system_clock","random_number","random_seed"] >>= withAttribute "Non elemental subroutine")))
return (attr, result)
parseRules "find_numbers" =
do (attr, result) <- (((pRegExpr (compileRegex "[0-9]*\\.[0-9]+([de][+-]?[0-9]+)?([_]([0-9]+|[a-z][\\w_]*))?") >>= withAttribute "Float"))
<|>
((pRegExpr (compileRegex "\\b[0-9]+\\.[0-9]*([de][+-]?[0-9]+)?([_]([0-9]+|[a-z][\\w_]*))?(?![a-z])") >>= withAttribute "Float"))
<|>
((pRegExpr (compileRegex "\\b[0-9]+[de][+-]?[0-9]+([_]([0-9]+|[a-z][\\w_]*))?") >>= withAttribute "Float"))
<|>
((pRegExpr (compileRegex "\\b[0-9]+([_]([0-9]+|[a-zA-Z][\\w_]*))?") >>= withAttribute "Decimal"))
<|>
((pRegExpr (compileRegex "\\b[bozx](['][0-9a-f]+[']|[\"][0-9a-f]+[\"])") >>= withAttribute "Decimal")))
return (attr, result)
parseRules "find_strings" =
do (attr, result) <- (((pDetectChar False '\'' >>= withAttribute "String") >>~ pushContext "string_1")
<|>
((pDetectChar False '"' >>= withAttribute "String") >>~ pushContext "string_2"))
return (attr, result)
parseRules "string_1" =
do (attr, result) <- (((pRegExpr (compileRegex "[^']*'") >>= withAttribute "String") >>~ (popContext >> return ()))
<|>
((pRegExpr (compileRegex "&\\s*$") >>= withAttribute "Keyword") >>~ pushContext "end_of_string")
<|>
((pRegExpr (compileRegex ".*(?=&\\s*$)") >>= withAttribute "String") >>~ pushContext "end_of_string")
<|>
((popContext >> return ()) >> return ([], "")))
return (attr, result)
parseRules "string_2" =
do (attr, result) <- (((pRegExpr (compileRegex "[^\"]*\"") >>= withAttribute "String") >>~ (popContext >> return ()))
<|>
((pRegExpr (compileRegex "&\\s*$") >>= withAttribute "Keyword") >>~ pushContext "end_of_string")
<|>
((pRegExpr (compileRegex ".*(?=&\\s*$)") >>= withAttribute "String") >>~ pushContext "end_of_string")
<|>
((popContext >> return ()) >> return ([], "")))
return (attr, result)
parseRules "end_of_string" =
do (attr, result) <- (((pDetectSpaces >>= withAttribute "String"))
<|>
((pRegExpr (compileRegex "&\\s*$") >>= withAttribute "Keyword"))
<|>
((pFirstNonSpace >> pDetectChar False '&' >>= withAttribute "Keyword") >>~ (popContext >> return ()))
<|>
((pFirstNonSpace >> pRegExpr (compileRegex "(!.*)?$") >>= withAttribute "Comment"))
<|>
((popContext >> popContext >> return ()) >> return ([], "")))
return (attr, result)
parseRules x = fail $ "Unknown context" ++ x