{- This module was generated from data in the Kate syntax highlighting file postscript.xml, version 1.01,
   by   -}

module Text.Highlighting.Kate.Syntax.Postscript ( 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
-- | Full name of language.
syntaxName :: String
syntaxName = "PostScript"

-- | Filename extensions for this language.
syntaxExtensions :: String
syntaxExtensions = "*.ps;*.ai;*.eps"

-- | Highlight source code using this syntax definition.
highlight :: String -> Either String [SourceLine]
highlight input =
  case runParser parseSource startingState "source" input of
    Left err     -> Left $ show err
    Right result -> Right result

-- | Parse an expression using appropriate local context.
parseExpression :: GenParser Char SyntaxState LabeledSource
parseExpression = do
  st <- getState
  let oldLang = synStLanguage st
  setState $ st { synStLanguage = "PostScript" }
  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 [("PostScript",["Normal"])], synStLanguage = "PostScript", 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
    "Normal" -> return () >> pHandleEndLine
    "Comment" -> (popContext) >> pEndLine
    "Header" -> (popContext) >> pEndLine
    "String" -> 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"),("Header","ot"),("Float","fl"),("Decimal","dv"),("String","st"),("Data Type","dt")]

parseExpressionInternal = do
  context <- currentContext
  parseRules context <|> (pDefault >>= withAttribute (fromMaybe "" $ lookup context defaultAttributes))

list_keywords = Set.fromList $ words $ "abs add aload anchorsearch and arc arcn arct arcto array ashow astore awidthshow begin bind bitshift ceiling charpath clear cleartomark clip clippath closepath concat concatmatrix copy count counttomark currentcmykcolor currentdash currentdict currentfile currentfont currentgray currentgstate currenthsbcolor currentlinecap currentlinejoin currentlinewidth currentmatrix currentpoint currentrgbcolor currentshared curveto cvi cvlit cvn cvr cvrs cvs cvx def defineusername dict div dtransform dup end eoclip eofill eoviewclip eq exch exec exit file fill findfont flattenpath floor flush flushfile for forall ge get getinterval grestore gsave gstate gt identmatrix idiv idtransform if ifelse image imagemask index ineofill infill initviewclip inueofill inufill invertmatrix itransform known le length lineto load loop lt makefont matrix maxlength mod moveto mul ne neg newpath not null or pathbbox pathforall pop print printobject put putinterval rcurveto read readhexstring readline readstring rectclip rectfill rectstroke rectviewclip repeat restore rlineto rmoveto roll rotate round save scale scalefont search selectfont setbbox setcachedevice setcachedevice2 setcharwidth setcmykcolor setdash setfont setgray setgstate sethsbcolor setlinecap setlinejoin setlinewidth setmatrix setrgbcolor setshared shareddict show showpage stop stopped store string stringwidth stroke strokepath sub systemdict token transform translate truncate type uappend ucache ueofill ufill undef upath userdict ustroke viewclip viewclippath where widthshow write writehexstring writeobject writestring wtranslation xor xshow xyshow yshow fontdirectory sharedfontdirectory courier courier-bold courier-boldoblique courier-oblique helvetica helvetica-bold helvetica-boldoblique helvetica-oblique symbol times-bold times-bolditalic times-italic times-roman execuserobject currentcolor currentcolorspace currentglobal execform filter findresource globaldict makepattern setcolor setcolorspace setglobal setpagedevice setpattern isolatin1encoding standardencoding atan banddevice bytesavailable cachestatus closefile colorimage condition copypage cos countdictstack countexecstack cshow currentblackgeneration currentcacheparams currentcolorscreen currentcolortransfer currentcontext currentflat currenthalftone currenthalftonephase currentmiterlimit currentobjectformat currentpacking currentscreen currentstrokeadjust currenttransfer currentundercolorremoval defaultmatrix definefont deletefile detach deviceinfo dictstack echo erasepage errordict execstack executeonly exp false filenameforall fileposition fork framedevice grestoreall handleerror initclip initgraphics initmatrix instroke inustroke join kshow ln lock log mark monitor noaccess notify nulldevice packedarray quit rand rcheck readonly realtime renamefile renderbands resetfile reversepath rootfont rrand run scheck setblackgeneration setcachelimit setcacheparams setcolorscreen setcolortransfer setfileposition setflat sethalftone sethalftonephase setmiterlimit setobjectformat setpacking setscreen setstrokeadjust settransfer setucacheparams setundercolorremoval sin sqrt srand stack status statusdict true ucachestatus undefinefont usertime ustrokepath version vmreclaim vmstatus wait wcheck xcheck yield defineuserobject undefineuserobject userobjects cleardictstack setvmthreshold currentcolorrendering currentdevparams currentoverprint currentpagedevice currentsystemparams currentuserparams defineresource findencoding gcheck glyphshow languagelevel product pstack resourceforall resourcestatus revision serialnumber setcolorrendering setdevparams setoverprint setsystemparams setuserparams startjob undefineresource globalfontdirectory ascii85decode ascii85encode asciihexdecode asciihexencode ccittfaxdecode ccittfaxencode dctdecode dctencode lzwdecode lzwencode nullencode runlengthdecode runlengthencode subfiledecode ciebaseda ciebasedabc devicecmyk devicegray devicergb indexed pattern separation ciebaseddef ciebaseddefg devicen"

regex_'5c'2f'7b1'2c2'7d'5b'5e'5cs'5c'28'5c'29'5c'7b'5c'7d'5c'5b'5c'5d'25'2f'5d'2a = compileRegex "\\/{1,2}[^\\s\\(\\)\\{\\}\\[\\]%/]*"

defaultAttributes = [("Normal","Normal Text"),("Comment","Comment"),("Header","Header"),("String","String")]

parseRules "Normal" = 
  do (attr, result) <- (((pKeyword " \n\t.():!+,-<=>%&*/;?[]^{|}~\\" list_keywords >>= withAttribute "Keyword"))
                        <|>
                        ((pDetect2Chars False '%' '!' >>= withAttribute "Header") >>~ pushContext "Header")
                        <|>
                        ((pDetectChar False '%' >>= withAttribute "Comment") >>~ pushContext "Comment")
                        <|>
                        ((pFloat >>= withAttribute "Float"))
                        <|>
                        ((pInt >>= withAttribute "Decimal"))
                        <|>
                        ((pDetectChar False '(' >>= withAttribute "String") >>~ pushContext "String")
                        <|>
                        ((pRegExpr regex_'5c'2f'7b1'2c2'7d'5b'5e'5cs'5c'28'5c'29'5c'7b'5c'7d'5c'5b'5c'5d'25'2f'5d'2a >>= withAttribute "Data Type")))
     return (attr, result)

parseRules "Comment" = 
  pzero

parseRules "Header" = 
  pzero

parseRules "String" = 
  do (attr, result) <- ((pDetectChar False ')' >>= withAttribute "String") >>~ (popContext))
     return (attr, result)

parseRules x = fail $ "Unknown context" ++ x