diff --git a/Language/Java/Lexer.x b/Language/Java/Lexer.x --- a/Language/Java/Lexer.x +++ b/Language/Java/Lexer.x @@ -1,373 +1,373 @@ -{ -{-# LANGUAGE BangPatterns #-} -module Language.Java.Lexer (L(..), Token(..), lexer) where - -import Numeric -import Data.Char - -import Debug.Trace (trace) -} - -%wrapper "posn" - -$digit = [0-9] -$nonzero = [1-9] -$octdig = [0-7] -$hexdig = [0-9A-Fa-f] - -@lineterm = [\n\r] | \r\n - --- TODO: this doesn't notice a comment that ends "**/" -@tradcomm = "/*" ( ~[\*] | \*+ (~[\/\*] | \n) | \n )* \*+ "/" -@linecomm = "//" .* @lineterm -@comm = @tradcomm | @linecomm - -$javaLetter = [a-zA-Z\_\$] -$javaDigit = $digit -$javaLetterOrDigit = [a-zA-Z0-9\_\$] - -@octEscape = [0123]? $octdig{1,2} -@hexEscape = u $hexdig{4} -@charEscape = \\ (@octEscape | @hexEscape | [btnfr\"\'\\]) - -@expsuffix = [\+\-]? $digit+ -@exponent = [eE] @expsuffix -@pexponent = [pP] @expsuffix - -tokens :- - - $white+ ; - @comm ; - - abstract { \p _ -> L (pos p) $ KW_Abstract } - assert { \p _ -> L (pos p) $ KW_Assert } - boolean { \p _ -> L (pos p) $ KW_Boolean } - break { \p _ -> L (pos p) $ KW_Break } - byte { \p _ -> L (pos p) $ KW_Byte } - case { \p _ -> L (pos p) $ KW_Case } - catch { \p _ -> L (pos p) $ KW_Catch } - char { \p _ -> L (pos p) $ KW_Char } - class { \p _ -> L (pos p) $ KW_Class } - const { \p _ -> L (pos p) $ KW_Const } - continue { \p _ -> L (pos p) $ KW_Continue } - default { \p _ -> L (pos p) $ KW_Default } - do { \p _ -> L (pos p) $ KW_Do } - double { \p _ -> L (pos p) $ KW_Double } - else { \p _ -> L (pos p) $ KW_Else } - enum { \p _ -> L (pos p) $ KW_Enum } - extends { \p _ -> L (pos p) $ KW_Extends } - final { \p _ -> L (pos p) $ KW_Final } - finally { \p _ -> L (pos p) $ KW_Finally } - float { \p _ -> L (pos p) $ KW_Float } - for { \p _ -> L (pos p) $ KW_For } - goto { \p _ -> L (pos p) $ KW_Goto } - if { \p _ -> L (pos p) $ KW_If } - implements { \p _ -> L (pos p) $ KW_Implements } - import { \p _ -> L (pos p) $ KW_Import } - instanceof { \p _ -> L (pos p) $ KW_Instanceof } - int { \p _ -> L (pos p) $ KW_Int } - interface { \p _ -> L (pos p) $ KW_Interface } - long { \p _ -> L (pos p) $ KW_Long } - native { \p _ -> L (pos p) $ KW_Native } - new { \p _ -> L (pos p) $ KW_New } - package { \p _ -> L (pos p) $ KW_Package } - private { \p _ -> L (pos p) $ KW_Private } - protected { \p _ -> L (pos p) $ KW_Protected } - public { \p _ -> L (pos p) $ KW_Public } - return { \p _ -> L (pos p) $ KW_Return } - short { \p _ -> L (pos p) $ KW_Short } - static { \p _ -> L (pos p) $ KW_Static } - strictfp { \p _ -> L (pos p) $ KW_Strictfp } - super { \p _ -> L (pos p) $ KW_Super } - switch { \p _ -> L (pos p) $ KW_Switch } - synchronized { \p _ -> L (pos p) $ KW_Synchronized } - this { \p _ -> L (pos p) $ KW_This } - throw { \p _ -> L (pos p) $ KW_Throw } - throws { \p _ -> L (pos p) $ KW_Throws } - transient { \p _ -> L (pos p) $ KW_Transient } - try { \p _ -> L (pos p) $ KW_Try } - void { \p _ -> L (pos p) $ KW_Void } - volatile { \p _ -> L (pos p) $ KW_Volatile } - while { \p _ -> L (pos p) $ KW_While } - - 0 { \p _ -> L (pos p) $ IntTok 0 } - 0 [lL] { \p _ -> L (pos p) $ LongTok 0 } - 0 $digit+ { \p s -> L (pos p) $ IntTok (pickyReadOct s) } - 0 $digit+ [lL] { \p s -> L (pos p) $ LongTok (pickyReadOct (init s)) } - $nonzero $digit* { \p s -> L (pos p) $ IntTok (read s) } - $nonzero $digit* [lL] { \p s -> L (pos p) $ LongTok (read (init s)) } - 0 [xX] $hexdig+ { \p s -> L (pos p) $ IntTok (fst . head $ readHex (drop 2 s)) } - 0 [xX] $hexdig+ [lL] { \p s -> L (pos p) $ LongTok (fst . head $ readHex (init (drop 2 s))) } - - $digit+ \. $digit* @exponent? [dD]? { \p s -> L (pos p) $ DoubleTok (fst . head $ readFloat $ '0':s) } - \. $digit+ @exponent? [dD]? { \p s -> L (pos p) $ DoubleTok (fst . head $ readFloat $ '0':s) } - $digit+ \. $digit* @exponent? [fF] { \p s -> L (pos p) $ FloatTok (fst . head $ readFloat $ '0':s) } - \. $digit+ @exponent? [fF] { \p s -> L (pos p) $ FloatTok (fst . head $ readFloat $ '0':s) } - $digit+ @exponent { \p s -> L (pos p) $ DoubleTok (fst . head $ readFloat s) } - $digit+ @exponent? [dD] { \p s -> L (pos p) $ DoubleTok (fst . head $ readFloat s) } - $digit+ @exponent? [fF] { \p s -> L (pos p) $ FloatTok (fst . head $ readFloat s) } - 0 [xX] $hexdig* \.? $hexdig* @pexponent [dD]? { \p s -> L (pos p) $ DoubleTok (readHexExp (drop 2 s)) } - 0 [xX] $hexdig* \.? $hexdig* @pexponent [fF] { \p s -> L (pos p) $ FloatTok (readHexExp (drop 2 s)) } - - true { \p _ -> L (pos p) $ BoolTok True } - false { \p _ -> L (pos p) $ BoolTok False } - - ' (@charEscape | ~[\\\']) ' { \p s -> L (pos p) $ CharTok (readCharTok s) } - - \" (@charEscape | ~[\\\"])* \" { \p s -> L (pos p) $ StringTok (readStringTok s) } - - null {\p _ -> L (pos p) $ NullTok } - - $javaLetter $javaLetterOrDigit* { \p s -> L (pos p) $ IdentTok s } - - \( { \p _ -> L (pos p) $ OpenParen } - \) { \p _ -> L (pos p) $ CloseParen } - \[ { \p _ -> L (pos p) $ OpenSquare } - \] { \p _ -> L (pos p) $ CloseSquare } - \{ { \p _ -> L (pos p) $ OpenCurly } - \} { \p _ -> L (pos p) $ CloseCurly } - \; { \p _ -> L (pos p) $ SemiColon } - \, { \p _ -> L (pos p) $ Comma } - \. { \p _ -> L (pos p) $ Period } - - "=" { \p _ -> L (pos p) $ Op_Equal } - ">" { \p _ -> L (pos p) $ Op_GThan } - "<" { \p _ -> L (pos p) $ Op_LThan } - "!" { \p _ -> L (pos p) $ Op_Bang } - "~" { \p _ -> L (pos p) $ Op_Tilde } - "?" { \p _ -> L (pos p) $ Op_Query } - ":" { \p _ -> L (pos p) $ Op_Colon } - "==" { \p _ -> L (pos p) $ Op_Equals } - "<=" { \p _ -> L (pos p) $ Op_LThanE } - ">=" { \p _ -> L (pos p) $ Op_GThanE } - "!=" { \p _ -> L (pos p) $ Op_BangE } - "&&" { \p _ -> L (pos p) $ Op_AAnd } - "||" { \p _ -> L (pos p) $ Op_OOr } - "++" { \p _ -> L (pos p) $ Op_PPlus } - "--" { \p _ -> L (pos p) $ Op_MMinus } - "+" { \p _ -> L (pos p) $ Op_Plus } - "-" { \p _ -> L (pos p) $ Op_Minus } - "*" { \p _ -> L (pos p) $ Op_Star } - "/" { \p _ -> L (pos p) $ Op_Slash } - "&" { \p _ -> L (pos p) $ Op_And } - "|" { \p _ -> L (pos p) $ Op_Or } - "^" { \p _ -> L (pos p) $ Op_Caret } - "%" { \p _ -> L (pos p) $ Op_Percent } - "<<" { \p _ -> L (pos p) $ Op_LShift } - ">>" { \p _ -> L (pos p) $ Op_RShift } - ">>>" { \p _ -> L (pos p) $ Op_RRShift } - "+=" { \p _ -> L (pos p) $ Op_PlusE } - "-=" { \p _ -> L (pos p) $ Op_MinusE } - "*=" { \p _ -> L (pos p) $ Op_StarE } - "/=" { \p _ -> L (pos p) $ Op_SlashE } - "&=" { \p _ -> L (pos p) $ Op_AndE } - "|=" { \p _ -> L (pos p) $ Op_OrE } - "^=" { \p _ -> L (pos p) $ Op_CaretE } - "%=" { \p _ -> L (pos p) $ Op_PercentE } - "<<=" { \p _ -> L (pos p) $ Op_LShiftE } - ">>=" { \p _ -> L (pos p) $ Op_RShiftE } - ">>>=" { \p _ -> L (pos p) $ Op_RRShiftE } - "@" { \p _ -> L (pos p) $ Op_AtSign } - - -{ - -pickyReadOct :: String -> Integer -pickyReadOct s = - if not $ null rem - then lexicalError $ "Non-octal digit '" ++ take 1 rem ++ "' in \"" ++ s ++ "\"." - else n - where (n,rem) = head $ readOct s - -readHexExp :: (Floating a, Eq a) => String -> a -readHexExp s = let (m, suf) = head $ readHex s - (e, _) = case suf of - p:s | toLower p == 'p' -> head $ readHex s - _ -> (0, "") - in m ** e - -readCharTok :: String -> Char -readCharTok s = head . convChar . dropQuotes $ s -readStringTok :: String -> String -readStringTok = convChar . dropQuotes - -dropQuotes :: String -> String -dropQuotes s = take (length s - 2) (tail s) - --- Converts a sequence of (unquoted) Java character literals, including --- escapes, into the sequence of corresponding Chars. The calls to --- 'lexicalError' double-check that this function is consistent with --- the lexer rules for character and string literals. This function --- could be expressed as another Alex lexer, but it's simple enough --- to implement by hand. -convChar :: String -> String -convChar ('\\':'u':s@(d1:d2:d3:d4:s')) = - -- TODO: this is the wrong place for handling unicode escapes - -- according to the Java Language Specification. Unicode escapes can - -- appear anywhere in the source text, and are best processed - -- before lexing. - if all isHexDigit [d1,d2,d3,d4] - then toEnum (read ['0','x',d1,d2,d3,d4]):convChar s' - else lexicalError $ "bad unicode escape \"\\u" ++ take 4 s ++ "\"" -convChar ('\\':'u':s) = - lexicalError $ "bad unicode escape \"\\u" ++ take 4 s ++ "\"" -convChar ('\\':c:s) = - if isOctDigit c - then convOctal maxRemainingOctals - else (case c of - 'b' -> '\b' - 'f' -> '\f' - 'n' -> '\n' - 'r' -> '\r' - 't' -> '\t' - '\'' -> '\'' - '\\' -> '\\' - '"' -> '"' - _ -> badEscape):convChar s - where maxRemainingOctals = - if c <= '3' then 2 else 1 - convOctal n = - let octals = takeWhile isOctDigit $ take n s - noctals = length octals - toChar = toEnum . fst . head . readOct - in toChar (c:octals):convChar (drop noctals s) - badEscape = lexicalError $ "bad escape \"\\" ++ c:"\"" -convChar ("\\") = - lexicalError "bad escape \"\\\"" -convChar (x:s) = x:convChar s -convChar "" = "" - -lexicalError :: String -> a -lexicalError = error . ("lexical error: " ++) - -data L a = L Pos a - deriving (Show, Eq) - --- (line, column) -type Pos = (Int, Int) - -pos :: AlexPosn -> Pos -pos (AlexPn _ l c) = (l,c) - -data Token - -- Keywords - = KW_Abstract - | KW_Assert - | KW_Boolean - | KW_Break - | KW_Byte - | KW_Case - | KW_Catch - | KW_Char - | KW_Class - | KW_Const - | KW_Continue - | KW_Default - | KW_Do - | KW_Double - | KW_Else - | KW_Enum - | KW_Extends - | KW_Final - | KW_Finally - | KW_Float - | KW_For - | KW_Goto - | KW_If - | KW_Implements - | KW_Import - | KW_Instanceof - | KW_Int - | KW_Interface - | KW_Long - | KW_Native - | KW_New - | KW_Package - | KW_Private - | KW_Protected - | KW_Public - | KW_Return - | KW_Short - | KW_Static - | KW_Strictfp - | KW_Super - | KW_Switch - | KW_Synchronized - | KW_This - | KW_Throw - | KW_Throws - | KW_Transient - | KW_Try - | KW_Void - | KW_Volatile - | KW_While - - -- Separators - | OpenParen - | CloseParen - | OpenSquare - | CloseSquare - | OpenCurly - | CloseCurly - | SemiColon - | Comma - | Period - - -- Literals - | IntTok Integer - | LongTok Integer - | DoubleTok Double - | FloatTok Double - | CharTok Char - | StringTok String - | BoolTok Bool - | NullTok - - -- Identifiers - | IdentTok String - - -- Operators - | Op_Equal - | Op_GThan - | Op_LThan - | Op_Bang - | Op_Tilde - | Op_Query - | Op_Colon - | Op_Equals - | Op_LThanE - | Op_GThanE - | Op_BangE - | Op_AAnd - | Op_OOr - | Op_PPlus - | Op_MMinus - | Op_Plus - | Op_Minus - | Op_Star - | Op_Slash - | Op_And - | Op_Or - | Op_Caret - | Op_Percent - | Op_LShift - | Op_RShift - | Op_RRShift - | Op_PlusE - | Op_MinusE - | Op_StarE - | Op_SlashE - | Op_AndE - | Op_OrE - | Op_CaretE - | Op_PercentE - | Op_LShiftE - | Op_RShiftE - | Op_RRShiftE - | Op_AtSign - deriving (Show, Eq) - -lexer :: String -> [L Token] -lexer = alexScanTokens - -} +{ +{-# LANGUAGE BangPatterns #-} +module Language.Java.Lexer (L(..), Token(..), lexer) where + +import Numeric +import Data.Char + +import Debug.Trace (trace) +} + +%wrapper "posn" + +$digit = [0-9] +$nonzero = [1-9] +$octdig = [0-7] +$hexdig = [0-9A-Fa-f] + +@lineterm = [\n\r] | \r\n + +-- TODO: this doesn't notice a comment that ends "**/" +@tradcomm = "/*" ( ~[\*] | \*+ (~[\/\*] | \n) | \n )* \*+ "/" +@linecomm = "//" .* @lineterm +@comm = @tradcomm | @linecomm + +$javaLetter = [a-zA-Z\_\$] +$javaDigit = $digit +$javaLetterOrDigit = [a-zA-Z0-9\_\$] + +@octEscape = [0123]? $octdig{1,2} +@hexEscape = u $hexdig{4} +@charEscape = \\ (@octEscape | @hexEscape | [btnfr\"\'\\]) + +@expsuffix = [\+\-]? $digit+ +@exponent = [eE] @expsuffix +@pexponent = [pP] @expsuffix + +tokens :- + + $white+ ; + @comm ; + + abstract { \p _ -> L (pos p) $ KW_Abstract } + assert { \p _ -> L (pos p) $ KW_Assert } + boolean { \p _ -> L (pos p) $ KW_Boolean } + break { \p _ -> L (pos p) $ KW_Break } + byte { \p _ -> L (pos p) $ KW_Byte } + case { \p _ -> L (pos p) $ KW_Case } + catch { \p _ -> L (pos p) $ KW_Catch } + char { \p _ -> L (pos p) $ KW_Char } + class { \p _ -> L (pos p) $ KW_Class } + const { \p _ -> L (pos p) $ KW_Const } + continue { \p _ -> L (pos p) $ KW_Continue } + default { \p _ -> L (pos p) $ KW_Default } + do { \p _ -> L (pos p) $ KW_Do } + double { \p _ -> L (pos p) $ KW_Double } + else { \p _ -> L (pos p) $ KW_Else } + enum { \p _ -> L (pos p) $ KW_Enum } + extends { \p _ -> L (pos p) $ KW_Extends } + final { \p _ -> L (pos p) $ KW_Final } + finally { \p _ -> L (pos p) $ KW_Finally } + float { \p _ -> L (pos p) $ KW_Float } + for { \p _ -> L (pos p) $ KW_For } + goto { \p _ -> L (pos p) $ KW_Goto } + if { \p _ -> L (pos p) $ KW_If } + implements { \p _ -> L (pos p) $ KW_Implements } + import { \p _ -> L (pos p) $ KW_Import } + instanceof { \p _ -> L (pos p) $ KW_Instanceof } + int { \p _ -> L (pos p) $ KW_Int } + interface { \p _ -> L (pos p) $ KW_Interface } + long { \p _ -> L (pos p) $ KW_Long } + native { \p _ -> L (pos p) $ KW_Native } + new { \p _ -> L (pos p) $ KW_New } + package { \p _ -> L (pos p) $ KW_Package } + private { \p _ -> L (pos p) $ KW_Private } + protected { \p _ -> L (pos p) $ KW_Protected } + public { \p _ -> L (pos p) $ KW_Public } + return { \p _ -> L (pos p) $ KW_Return } + short { \p _ -> L (pos p) $ KW_Short } + static { \p _ -> L (pos p) $ KW_Static } + strictfp { \p _ -> L (pos p) $ KW_Strictfp } + super { \p _ -> L (pos p) $ KW_Super } + switch { \p _ -> L (pos p) $ KW_Switch } + synchronized { \p _ -> L (pos p) $ KW_Synchronized } + this { \p _ -> L (pos p) $ KW_This } + throw { \p _ -> L (pos p) $ KW_Throw } + throws { \p _ -> L (pos p) $ KW_Throws } + transient { \p _ -> L (pos p) $ KW_Transient } + try { \p _ -> L (pos p) $ KW_Try } + void { \p _ -> L (pos p) $ KW_Void } + volatile { \p _ -> L (pos p) $ KW_Volatile } + while { \p _ -> L (pos p) $ KW_While } + + 0 { \p _ -> L (pos p) $ IntTok 0 } + 0 [lL] { \p _ -> L (pos p) $ LongTok 0 } + 0 $digit+ { \p s -> L (pos p) $ IntTok (pickyReadOct s) } + 0 $digit+ [lL] { \p s -> L (pos p) $ LongTok (pickyReadOct (init s)) } + $nonzero $digit* { \p s -> L (pos p) $ IntTok (read s) } + $nonzero $digit* [lL] { \p s -> L (pos p) $ LongTok (read (init s)) } + 0 [xX] $hexdig+ { \p s -> L (pos p) $ IntTok (fst . head $ readHex (drop 2 s)) } + 0 [xX] $hexdig+ [lL] { \p s -> L (pos p) $ LongTok (fst . head $ readHex (init (drop 2 s))) } + + $digit+ \. $digit* @exponent? [dD]? { \p s -> L (pos p) $ DoubleTok (fst . head $ readFloat $ '0':s) } + \. $digit+ @exponent? [dD]? { \p s -> L (pos p) $ DoubleTok (fst . head $ readFloat $ '0':s) } + $digit+ \. $digit* @exponent? [fF] { \p s -> L (pos p) $ FloatTok (fst . head $ readFloat $ '0':s) } + \. $digit+ @exponent? [fF] { \p s -> L (pos p) $ FloatTok (fst . head $ readFloat $ '0':s) } + $digit+ @exponent { \p s -> L (pos p) $ DoubleTok (fst . head $ readFloat s) } + $digit+ @exponent? [dD] { \p s -> L (pos p) $ DoubleTok (fst . head $ readFloat s) } + $digit+ @exponent? [fF] { \p s -> L (pos p) $ FloatTok (fst . head $ readFloat s) } + 0 [xX] $hexdig* \.? $hexdig* @pexponent [dD]? { \p s -> L (pos p) $ DoubleTok (readHexExp (drop 2 s)) } + 0 [xX] $hexdig* \.? $hexdig* @pexponent [fF] { \p s -> L (pos p) $ FloatTok (readHexExp (drop 2 s)) } + + true { \p _ -> L (pos p) $ BoolTok True } + false { \p _ -> L (pos p) $ BoolTok False } + + ' (@charEscape | ~[\\\']) ' { \p s -> L (pos p) $ CharTok (readCharTok s) } + + \" (@charEscape | ~[\\\"])* \" { \p s -> L (pos p) $ StringTok (readStringTok s) } + + null {\p _ -> L (pos p) $ NullTok } + + $javaLetter $javaLetterOrDigit* { \p s -> L (pos p) $ IdentTok s } + + \( { \p _ -> L (pos p) $ OpenParen } + \) { \p _ -> L (pos p) $ CloseParen } + \[ { \p _ -> L (pos p) $ OpenSquare } + \] { \p _ -> L (pos p) $ CloseSquare } + \{ { \p _ -> L (pos p) $ OpenCurly } + \} { \p _ -> L (pos p) $ CloseCurly } + \; { \p _ -> L (pos p) $ SemiColon } + \, { \p _ -> L (pos p) $ Comma } + \. { \p _ -> L (pos p) $ Period } + + "=" { \p _ -> L (pos p) $ Op_Equal } + ">" { \p _ -> L (pos p) $ Op_GThan } + "<" { \p _ -> L (pos p) $ Op_LThan } + "!" { \p _ -> L (pos p) $ Op_Bang } + "~" { \p _ -> L (pos p) $ Op_Tilde } + "?" { \p _ -> L (pos p) $ Op_Query } + ":" { \p _ -> L (pos p) $ Op_Colon } + "==" { \p _ -> L (pos p) $ Op_Equals } + "<=" { \p _ -> L (pos p) $ Op_LThanE } + ">=" { \p _ -> L (pos p) $ Op_GThanE } + "!=" { \p _ -> L (pos p) $ Op_BangE } + "&&" { \p _ -> L (pos p) $ Op_AAnd } + "||" { \p _ -> L (pos p) $ Op_OOr } + "++" { \p _ -> L (pos p) $ Op_PPlus } + "--" { \p _ -> L (pos p) $ Op_MMinus } + "+" { \p _ -> L (pos p) $ Op_Plus } + "-" { \p _ -> L (pos p) $ Op_Minus } + "*" { \p _ -> L (pos p) $ Op_Star } + "/" { \p _ -> L (pos p) $ Op_Slash } + "&" { \p _ -> L (pos p) $ Op_And } + "|" { \p _ -> L (pos p) $ Op_Or } + "^" { \p _ -> L (pos p) $ Op_Caret } + "%" { \p _ -> L (pos p) $ Op_Percent } + "<<" { \p _ -> L (pos p) $ Op_LShift } + ">>" { \p _ -> L (pos p) $ Op_RShift } + ">>>" { \p _ -> L (pos p) $ Op_RRShift } + "+=" { \p _ -> L (pos p) $ Op_PlusE } + "-=" { \p _ -> L (pos p) $ Op_MinusE } + "*=" { \p _ -> L (pos p) $ Op_StarE } + "/=" { \p _ -> L (pos p) $ Op_SlashE } + "&=" { \p _ -> L (pos p) $ Op_AndE } + "|=" { \p _ -> L (pos p) $ Op_OrE } + "^=" { \p _ -> L (pos p) $ Op_CaretE } + "%=" { \p _ -> L (pos p) $ Op_PercentE } + "<<=" { \p _ -> L (pos p) $ Op_LShiftE } + ">>=" { \p _ -> L (pos p) $ Op_RShiftE } + ">>>=" { \p _ -> L (pos p) $ Op_RRShiftE } + "@" { \p _ -> L (pos p) $ Op_AtSign } + + +{ + +pickyReadOct :: String -> Integer +pickyReadOct s = + if not $ null rem + then lexicalError $ "Non-octal digit '" ++ take 1 rem ++ "' in \"" ++ s ++ "\"." + else n + where (n,rem) = head $ readOct s + +readHexExp :: (Floating a, Eq a) => String -> a +readHexExp s = let (m, suf) = head $ readHex s + (e, _) = case suf of + p:s | toLower p == 'p' -> head $ readHex s + _ -> (0, "") + in m ** e + +readCharTok :: String -> Char +readCharTok s = head . convChar . dropQuotes $ s +readStringTok :: String -> String +readStringTok = convChar . dropQuotes + +dropQuotes :: String -> String +dropQuotes s = take (length s - 2) (tail s) + +-- Converts a sequence of (unquoted) Java character literals, including +-- escapes, into the sequence of corresponding Chars. The calls to +-- 'lexicalError' double-check that this function is consistent with +-- the lexer rules for character and string literals. This function +-- could be expressed as another Alex lexer, but it's simple enough +-- to implement by hand. +convChar :: String -> String +convChar ('\\':'u':s@(d1:d2:d3:d4:s')) = + -- TODO: this is the wrong place for handling unicode escapes + -- according to the Java Language Specification. Unicode escapes can + -- appear anywhere in the source text, and are best processed + -- before lexing. + if all isHexDigit [d1,d2,d3,d4] + then toEnum (read ['0','x',d1,d2,d3,d4]):convChar s' + else lexicalError $ "bad unicode escape \"\\u" ++ take 4 s ++ "\"" +convChar ('\\':'u':s) = + lexicalError $ "bad unicode escape \"\\u" ++ take 4 s ++ "\"" +convChar ('\\':c:s) = + if isOctDigit c + then convOctal maxRemainingOctals + else (case c of + 'b' -> '\b' + 'f' -> '\f' + 'n' -> '\n' + 'r' -> '\r' + 't' -> '\t' + '\'' -> '\'' + '\\' -> '\\' + '"' -> '"' + _ -> badEscape):convChar s + where maxRemainingOctals = + if c <= '3' then 2 else 1 + convOctal n = + let octals = takeWhile isOctDigit $ take n s + noctals = length octals + toChar = toEnum . fst . head . readOct + in toChar (c:octals):convChar (drop noctals s) + badEscape = lexicalError $ "bad escape \"\\" ++ c:"\"" +convChar ("\\") = + lexicalError "bad escape \"\\\"" +convChar (x:s) = x:convChar s +convChar "" = "" + +lexicalError :: String -> a +lexicalError = error . ("lexical error: " ++) + +data L a = L Pos a + deriving (Show, Eq) + +-- (line, column) +type Pos = (Int, Int) + +pos :: AlexPosn -> Pos +pos (AlexPn _ l c) = (l,c) + +data Token + -- Keywords + = KW_Abstract + | KW_Assert + | KW_Boolean + | KW_Break + | KW_Byte + | KW_Case + | KW_Catch + | KW_Char + | KW_Class + | KW_Const + | KW_Continue + | KW_Default + | KW_Do + | KW_Double + | KW_Else + | KW_Enum + | KW_Extends + | KW_Final + | KW_Finally + | KW_Float + | KW_For + | KW_Goto + | KW_If + | KW_Implements + | KW_Import + | KW_Instanceof + | KW_Int + | KW_Interface + | KW_Long + | KW_Native + | KW_New + | KW_Package + | KW_Private + | KW_Protected + | KW_Public + | KW_Return + | KW_Short + | KW_Static + | KW_Strictfp + | KW_Super + | KW_Switch + | KW_Synchronized + | KW_This + | KW_Throw + | KW_Throws + | KW_Transient + | KW_Try + | KW_Void + | KW_Volatile + | KW_While + + -- Separators + | OpenParen + | CloseParen + | OpenSquare + | CloseSquare + | OpenCurly + | CloseCurly + | SemiColon + | Comma + | Period + + -- Literals + | IntTok Integer + | LongTok Integer + | DoubleTok Double + | FloatTok Double + | CharTok Char + | StringTok String + | BoolTok Bool + | NullTok + + -- Identifiers + | IdentTok String + + -- Operators + | Op_Equal + | Op_GThan + | Op_LThan + | Op_Bang + | Op_Tilde + | Op_Query + | Op_Colon + | Op_Equals + | Op_LThanE + | Op_GThanE + | Op_BangE + | Op_AAnd + | Op_OOr + | Op_PPlus + | Op_MMinus + | Op_Plus + | Op_Minus + | Op_Star + | Op_Slash + | Op_And + | Op_Or + | Op_Caret + | Op_Percent + | Op_LShift + | Op_RShift + | Op_RRShift + | Op_PlusE + | Op_MinusE + | Op_StarE + | Op_SlashE + | Op_AndE + | Op_OrE + | Op_CaretE + | Op_PercentE + | Op_LShiftE + | Op_RShiftE + | Op_RRShiftE + | Op_AtSign + deriving (Show, Eq) + +lexer :: String -> [L Token] +lexer = alexScanTokens + +} diff --git a/Language/Java/Pretty.hs b/Language/Java/Pretty.hs --- a/Language/Java/Pretty.hs +++ b/Language/Java/Pretty.hs @@ -1,564 +1,564 @@ -module Language.Java.Pretty where - -import Text.PrettyPrint -import Data.Char (toLower) -import Data.List (intersperse) - -import Language.Java.Syntax - - -prettyPrint :: Pretty a => a -> String -prettyPrint = show . pretty - -parenPrec :: Int -> Int -> Doc -> Doc -parenPrec inheritedPrec currentPrec t - | inheritedPrec <= 0 = t - | inheritedPrec < currentPrec = parens t - | otherwise = t - -class Pretty a where - pretty :: a -> Doc - pretty = prettyPrec 0 - - prettyPrec :: Int -> a -> Doc - prettyPrec _ = pretty - ------------------------------------------------------------------------ --- Packages - -instance Pretty CompilationUnit where - pretty (CompilationUnit mpd ids tds) = - vcat $ maybePP mpd: map pretty ids ++ map pretty tds - -instance Pretty PackageDecl where - pretty (PackageDecl name) = text "package" <+> pretty name <> semi - -instance Pretty ImportDecl where - pretty (ImportDecl st name wc) = - text "import" <+> opt st (text "static") - <+> pretty name <> opt wc (text ".*") - <> semi - ------------------------------------------------------------------------ --- Declarations - -instance Pretty TypeDecl where - pretty (ClassTypeDecl cd) = pretty cd - pretty (InterfaceTypeDecl id) = pretty id - -instance Pretty ClassDecl where - pretty (EnumDecl mods ident impls body) = - hsep [hsep (map pretty mods) - , text "enum" - , pretty ident - , ppImplements impls - ] $$ pretty body - - pretty (ClassDecl mods ident tParams mSuper impls body) = - hsep [hsep (map pretty mods) - , text "class" - , pretty ident - , ppTypeParams tParams - , ppExtends (maybe [] return mSuper) - , ppImplements impls - ] $$ pretty body - -instance Pretty ClassBody where - pretty (ClassBody ds) = - braceBlock (map pretty ds) - -instance Pretty EnumBody where - pretty (EnumBody cs ds) = - braceBlock $ - punctuate comma (map pretty cs) ++ - opt (not $ null ds) semi : map pretty ds - -instance Pretty EnumConstant where - pretty (EnumConstant ident args mBody) = - pretty ident - -- needs special treatment since even the parens are optional - <> opt (not $ null args) (ppArgs args) - $$ maybePP mBody - -instance Pretty InterfaceDecl where - pretty (InterfaceDecl mods ident tParams impls body) = - hsep [hsep (map pretty mods) - , text "interface" - , pretty ident - , ppTypeParams tParams - , ppImplements impls - ] $$ pretty body - -instance Pretty InterfaceBody where - pretty (InterfaceBody mds) = - braceBlock (map pretty mds) - -instance Pretty Decl where - pretty (MemberDecl md) = pretty md - pretty (InitDecl b bl) = - opt b (text "static") <+> pretty bl - -instance Pretty MemberDecl where - pretty (FieldDecl mods t vds) = - hsep (map pretty mods ++ pretty t:map pretty vds) <> semi - - pretty (MethodDecl mods tParams mt ident fParams throws body) = - hsep [hsep (map pretty mods) - , ppTypeParams tParams - , ppResultType mt - , pretty ident - , ppArgs fParams - , ppThrows throws - ] $$ pretty body - - pretty (ConstructorDecl mods tParams ident fParams throws body) = - hsep [hsep (map pretty mods) - , ppTypeParams tParams - , pretty ident - , ppArgs fParams - , ppThrows throws - ] $$ pretty body - - pretty (MemberClassDecl cd) = pretty cd - pretty (MemberInterfaceDecl id) = pretty id - -instance Pretty VarDecl where - pretty (VarDecl vdId Nothing) = pretty vdId - pretty (VarDecl vdId (Just ie)) = - (pretty vdId <+> char '=') <+> pretty ie - -instance Pretty VarDeclId where - pretty (VarId ident) = pretty ident - pretty (VarDeclArray vId) = pretty vId - -instance Pretty VarInit where - pretty (InitExp e) = pretty e - pretty (InitArray (ArrayInit ai)) = - text "{" <+> hsep (punctuate comma (map pretty ai)) <+> text "}" - -instance Pretty FormalParam where - pretty (FormalParam mods t b vId) = - hsep [hsep (map pretty mods) - , pretty t <> opt b (text "...") - , pretty vId - ] - -instance Pretty MethodBody where - pretty (MethodBody mBlock) = maybe semi pretty mBlock - -instance Pretty ConstructorBody where - pretty (ConstructorBody mECI stmts) = - braceBlock $ maybePP mECI : map pretty stmts - -instance Pretty ExplConstrInv where - pretty (ThisInvoke rts args) = - ppTypeParams rts <+> text "this" <> ppArgs args <> semi - pretty (SuperInvoke rts args) = - ppTypeParams rts <+> text "super" <> ppArgs args <> semi - pretty (PrimarySuperInvoke e rts args) = - pretty e <> char '.' <> - ppTypeParams rts <+> text "super" <> ppArgs args <> semi - -instance Pretty Modifier where - pretty (Annotation ann) = pretty ann $+$ nest (-1) ( text "") - pretty mod = text . map toLower $ show mod - -instance Pretty Annotation where - pretty x = text "@" <> pretty (annName x) <> case x of - MarkerAnnotation {} -> text "" - SingleElementAnnotation {} -> text "(" <> pretty (annValue x) <> text ")" - NormalAnnotation {} -> text "(" <> ppEVList (annKV x) <> text ")" - -ppEVList = hsep . punctuate comma . map (\(k,v) -> pretty k <+> text "=" <+> pretty v) - -instance Pretty ElementValue where - pretty (EVVal vi) = pretty vi - pretty (EVAnn ann) = pretty ann - ------------------------------------------------------------------------ --- Statements - - -instance Pretty Block where - pretty (Block stmts) = braceBlock $ map pretty stmts - -instance Pretty BlockStmt where - pretty (BlockStmt stmt) = pretty stmt - pretty (LocalClass cd) = pretty cd - pretty (LocalVars mods t vds) = - hsep (map pretty mods) <+> pretty t <+> - hsep (punctuate comma $ map pretty vds) <> semi - -instance Pretty Stmt where - pretty (StmtBlock block) = pretty block - pretty (IfThen c th) = - text "if" <+> parens (prettyPrec 0 c) $+$ prettyNestedStmt th - - pretty (IfThenElse c th el) = - text "if" <+> parens (pretty c) $+$ prettyNestedStmt th $+$ text "else" $+$ prettyNestedStmt el - - pretty (While c stmt) = - text "while" <+> parens (pretty c) $+$ prettyNestedStmt stmt - - pretty (BasicFor mInit mE mUp stmt) = - text "for" <+> (parens $ hsep [maybePP mInit, semi - , maybePP mE, semi - , maybe empty (hsep . punctuate comma . map pretty) mUp - ]) $+$ prettyNestedStmt stmt - - pretty (EnhancedFor mods t ident e stmt) = - hsep [text "for" - , parens $ hsep [ - hsep (map pretty mods) - , pretty t - , pretty ident - , colon - , pretty e - ] - , pretty stmt - ] - - pretty Empty = semi - - pretty (ExpStmt e) = pretty e <> semi - - pretty (Assert ass mE) = - text "assert" <+> pretty ass - <+> maybe empty ((colon <>) . pretty) mE <> semi - - pretty (Switch e sBlocks) = - text "switch" <+> parens (pretty e) - $$ braceBlock (map pretty sBlocks) - - pretty (Do stmt e) = - text "do" $+$ pretty stmt <+> text "while" <+> parens (pretty e) <> semi - - pretty (Break mIdent) = - text "break" <+> maybePP mIdent <> semi - - pretty (Continue mIdent) = - text "continue" <+> maybePP mIdent <> semi - - pretty (Return mE) = - text "return" <+> maybePP mE <> semi - - pretty (Synchronized e block) = - text "synchronized" <+> parens (pretty e) $$ pretty block - - pretty (Throw e) = - text "throw" <+> pretty e <> semi - - pretty (Try block catches mFinally) = - text "try" $$ pretty block $$ - vcat (map pretty catches ++ [ppFinally mFinally]) - where ppFinally Nothing = empty - ppFinally (Just bl) = text "finally" <+> pretty bl - - pretty (Labeled ident stmt) = - pretty ident <> colon <+> pretty stmt - -instance Pretty Catch where - pretty (Catch fParam block) = - hsep [text "catch", parens (pretty fParam)] $$ pretty block - -instance Pretty SwitchBlock where - pretty (SwitchBlock lbl stmts) = - vcat (pretty lbl : map (nest 2 . pretty) stmts) - -instance Pretty SwitchLabel where - pretty (SwitchCase e) = - text "case" <+> pretty e <> colon - pretty Default = text "default:" - -instance Pretty ForInit where - pretty (ForLocalVars mods t vds) = - hsep $ map pretty mods ++ - pretty t: punctuate comma (map pretty vds) - pretty (ForInitExps es) = - hsep $ punctuate comma (map pretty es) - - ------------------------------------------------------------------------ --- Expressions - -instance Pretty Exp where - prettyPrec _ (Lit l) = pretty l - - prettyPrec _ (ClassLit mT) = - ppResultType mT <> text ".class" - - prettyPrec _ This = text "this" - - prettyPrec _ (ThisClass name) = - pretty name <> text ".this" - - prettyPrec _ (InstanceCreation tArgs ct args mBody) = - hsep [text "new" - , ppTypeParams tArgs - , pretty ct <> ppArgs args - ] $$ maybePP mBody - - prettyPrec _ (QualInstanceCreation e tArgs ident args mBody) = - hsep [pretty e <> char '.' <> text "new" - , ppTypeParams tArgs - , pretty ident <> ppArgs args - ] $$ maybePP mBody - - prettyPrec _ (ArrayCreate t es k) = - text "new" <+> - hcat (pretty t : map (brackets . pretty) es - ++ replicate k (text "[]")) - - prettyPrec _ (ArrayCreateInit t k init) = - text "new" - <+> hcat (pretty t : replicate k (text "[]")) - <+> pretty init - - prettyPrec p (FieldAccess fa) = parenPrec p 1 $ prettyPrec 1 fa - - prettyPrec p (MethodInv mi) = parenPrec p 1 $ prettyPrec 1 mi - - prettyPrec p (ArrayAccess ain) = parenPrec p 1 $ prettyPrec 1 ain - - prettyPrec _ (ExpName name) = pretty name - - prettyPrec p (PostIncrement e) = parenPrec p 2 $ prettyPrec 2 e <> text "++" - - prettyPrec p (PostDecrement e) = parenPrec p 2 $ prettyPrec 2 e <> text "--" - - prettyPrec p (PreIncrement e) = parenPrec p 2 $ text "++" <> prettyPrec 2 e - - prettyPrec p (PreDecrement e) = parenPrec p 2 $ text "--" <> prettyPrec 2 e - - prettyPrec p (PrePlus e) = parenPrec p 2 $ char '+' <> prettyPrec 2 e - - prettyPrec p (PreMinus e) = parenPrec p 2 $ char '-' <> prettyPrec 2 e - - prettyPrec p (PreBitCompl e) = parenPrec p 2 $ char '~' <> prettyPrec 2 e - - prettyPrec p (PreNot e) = parenPrec p 2 $ char '!' <> prettyPrec 2 e - - prettyPrec p (Cast t e) = parenPrec p 2 $ parens (pretty t) <+> prettyPrec 2 e - - prettyPrec p (BinOp e1 op e2) = - let prec = opPrec op in - parenPrec p prec (prettyPrec prec e1 <+> pretty op <+> prettyPrec prec e2) - - prettyPrec p (InstanceOf e rt) = - let cp = opPrec LThan in - parenPrec p cp $ prettyPrec cp e - <+> text "instanceof" <+> prettyPrec cp rt - - prettyPrec p (Cond c th el) = - parenPrec p 13 $ prettyPrec 13 c <+> char '?' - <+> pretty th <+> colon <+> prettyPrec 13 el - - prettyPrec _ (Assign lhs aop e) = - hsep [pretty lhs, pretty aop, pretty e] - - -instance Pretty Literal where - pretty (Int i) = text (show i) - pretty (Word i) = text (show i) <> char 'L' - pretty (Float f) = text (show f) <> char 'F' - pretty (Double d) = text (show d) - pretty (Boolean b) = text . map toLower $ show b - pretty (Char c) = text (show c) - pretty (String s) = text (show s) - pretty (Null) = text "null" - -instance Pretty Op where - pretty op = text $ case op of - Mult -> "*" - Div -> "/" - Rem -> "%" - Add -> "+" - Sub -> "-" - LShift -> "<<" - RShift -> ">>" - RRShift -> ">>>" - LThan -> "<" - GThan -> ">" - LThanE -> "<=" - GThanE -> ">=" - Equal -> "==" - NotEq -> "!=" - And -> "&" - Xor -> "^" - Or -> "|" - CAnd -> "&&" - COr -> "||" - -instance Pretty AssignOp where - pretty aop = text $ case aop of - EqualA -> "=" - MultA -> "*=" - DivA -> "/=" - RemA -> "%=" - AddA -> "+=" - SubA -> "-=" - LShiftA -> "<<=" - RShiftA -> ">>=" - RRShiftA -> ">>>=" - AndA -> "&=" - XorA -> "^=" - OrA -> "|=" - -instance Pretty Lhs where - pretty (NameLhs name) = pretty name - pretty (FieldLhs fa) = pretty fa - pretty (ArrayLhs ain) = pretty ain - -instance Pretty ArrayIndex where - pretty (ArrayIndex ref e) = pretty ref <> brackets (pretty e) - -instance Pretty FieldAccess where - pretty (PrimaryFieldAccess e ident) = - pretty e <> char '.' <> pretty ident - pretty (SuperFieldAccess ident) = - text "super." <> pretty ident - pretty (ClassFieldAccess name ident) = - pretty name <> text ".super." <> pretty ident - -instance Pretty MethodInvocation where - pretty (MethodCall name args) = - pretty name <> ppArgs args - - pretty (PrimaryMethodCall e tArgs ident args) = - hcat [pretty e, char '.', ppTypeParams tArgs, - pretty ident, ppArgs args] - - pretty (SuperMethodCall tArgs ident args) = - hcat [text "super.", ppTypeParams tArgs, - pretty ident, ppArgs args] - - pretty (ClassMethodCall name tArgs ident args) = - hcat [pretty name, text ".super.", ppTypeParams tArgs, - pretty ident, ppArgs args] - - pretty (TypeMethodCall name tArgs ident args) = - hcat [pretty name, char '.', ppTypeParams tArgs, - pretty ident, ppArgs args] - -instance Pretty ArrayInit where - pretty (ArrayInit vInits) = - braceBlock $ map (\v -> pretty v <> comma) vInits - --braces $ hsep (punctuate comma (map pretty vInits)) - - -ppArgs :: Pretty a => [a] -> Doc -ppArgs = parens . hsep . punctuate comma . map pretty - ------------------------------------------------------------------------ --- Types - -instance Pretty Type where - pretty (PrimType pt) = pretty pt - pretty (RefType rt) = pretty rt - -instance Pretty RefType where - pretty (ClassRefType ct) = pretty ct - pretty (ArrayType t) = pretty t <> text "[]" - -instance Pretty ClassType where - pretty (ClassType itas) = - hcat . punctuate (char '.') $ - map (\(i,tas) -> pretty i <> ppTypeParams tas) itas - -instance Pretty TypeArgument where - pretty (ActualType rt) = pretty rt - pretty (Wildcard mBound) = char '?' <+> maybePP mBound - -instance Pretty WildcardBound where - pretty (ExtendsBound rt) = text "extends" <+> pretty rt - pretty (SuperBound rt) = text "super" <+> pretty rt - -instance Pretty PrimType where - pretty BooleanT = text "boolean" - pretty ByteT = text "byte" - pretty ShortT = text "short" - pretty IntT = text "int" - pretty LongT = text "long" - pretty CharT = text "char" - pretty FloatT = text "float" - pretty DoubleT = text "double" - -instance Pretty TypeParam where - pretty (TypeParam ident rts) = - pretty ident - <+> opt (not $ null rts) - (hsep $ text "extends": - punctuate (text " &") (map pretty rts)) - -ppTypeParams :: Pretty a => [a] -> Doc -ppTypeParams [] = empty -ppTypeParams tps = char '<' - <> hsep (punctuate comma (map pretty tps)) - <> char '>' - -ppImplements :: [RefType] -> Doc -ppImplements [] = empty -ppImplements rts = text "implements" - <+> hsep (punctuate comma (map pretty rts)) - -ppExtends :: [RefType] -> Doc -ppExtends [] = empty -ppExtends rts = text "extends" - <+> hsep (punctuate comma (map pretty rts)) - -ppThrows :: [ExceptionType] -> Doc -ppThrows [] = empty -ppThrows ets = text "throws" - <+> hsep (punctuate comma (map pretty ets)) - -ppResultType :: Maybe Type -> Doc -ppResultType Nothing = text "void" -ppResultType (Just a) = pretty a - ------------------------------------------------------------------------ --- Names and identifiers - -instance Pretty Name where - pretty (Name is) = - hcat (punctuate (char '.') $ map pretty is) - -instance Pretty Ident where - pretty (Ident s) = text s - - ------------------------------------------------------------------------ --- Help functionality -prettyNestedStmt :: Stmt -> Doc -prettyNestedStmt p@(StmtBlock b) = pretty p -prettyNestedStmt p = nest 2 (pretty p) - -maybePP :: Pretty a => Maybe a -> Doc -maybePP = maybe empty pretty - -opt :: Bool -> Doc -> Doc -opt x a = if x then a else empty - -braceBlock :: [Doc] -> Doc -braceBlock xs = char '{' - $+$ nest 2 (vcat xs) - $+$ char '}' - -opPrec Mult = 3 -opPrec Div = 3 -opPrec Rem = 3 -opPrec Add = 4 -opPrec Sub = 4 -opPrec LShift = 5 -opPrec RShift = 5 -opPrec RRShift = 5 -opPrec LThan = 6 -opPrec GThan = 6 -opPrec LThanE = 6 -opPrec GThanE = 6 -opPrec Equal = 7 -opPrec NotEq = 7 -opPrec And = 8 -opPrec Xor = 9 -opPrec Or = 10 -opPrec CAnd = 11 -opPrec COr = 12 +module Language.Java.Pretty where + +import Text.PrettyPrint +import Data.Char (toLower) +import Data.List (intersperse) + +import Language.Java.Syntax + + +prettyPrint :: Pretty a => a -> String +prettyPrint = show . pretty + +parenPrec :: Int -> Int -> Doc -> Doc +parenPrec inheritedPrec currentPrec t + | inheritedPrec <= 0 = t + | inheritedPrec < currentPrec = parens t + | otherwise = t + +class Pretty a where + pretty :: a -> Doc + pretty = prettyPrec 0 + + prettyPrec :: Int -> a -> Doc + prettyPrec _ = pretty + +----------------------------------------------------------------------- +-- Packages + +instance Pretty CompilationUnit where + prettyPrec p (CompilationUnit mpd ids tds) = + vcat $ ((maybePP p mpd): map (prettyPrec p) ids) ++ map (prettyPrec p) tds + +instance Pretty PackageDecl where + prettyPrec p (PackageDecl name) = text "package" <+> prettyPrec p name <> semi + +instance Pretty ImportDecl where + prettyPrec p (ImportDecl st name wc) = + text "import" <+> opt st (text "static") + <+> prettyPrec p name <> opt wc (text ".*") + <> semi + +----------------------------------------------------------------------- +-- Declarations + +instance Pretty TypeDecl where + prettyPrec p (ClassTypeDecl cd) = prettyPrec p cd + prettyPrec p (InterfaceTypeDecl id) = prettyPrec p id + +instance Pretty ClassDecl where + prettyPrec p (EnumDecl mods ident impls body) = + hsep [hsep (map (prettyPrec p) mods) + , text "enum" + , prettyPrec p ident + , ppImplements p impls + ] $$ prettyPrec p body + + prettyPrec p (ClassDecl mods ident tParams mSuper impls body) = + hsep [hsep (map (prettyPrec p) mods) + , text "class" + , prettyPrec p ident + , ppTypeParams p tParams + , ppExtends p (maybe [] return mSuper) + , ppImplements p impls + ] $$ prettyPrec p body + +instance Pretty ClassBody where + prettyPrec p (ClassBody ds) = + braceBlock (map (prettyPrec p) ds) + +instance Pretty EnumBody where + prettyPrec p (EnumBody cs ds) = + braceBlock $ + punctuate comma (map (prettyPrec p) cs) ++ + opt (not $ null ds) semi : map (prettyPrec p) ds + +instance Pretty EnumConstant where + prettyPrec p (EnumConstant ident args mBody) = + prettyPrec p ident + -- needs special treatment since even the parens are optional + <> opt (not $ null args) (ppArgs p args) + $$ maybePP p mBody + +instance Pretty InterfaceDecl where + prettyPrec p (InterfaceDecl mods ident tParams impls body) = + hsep [hsep (map (prettyPrec p) mods) + , text "interface" + , prettyPrec p ident + , ppTypeParams p tParams + , ppImplements p impls + ] $$ prettyPrec p body + +instance Pretty InterfaceBody where + prettyPrec p (InterfaceBody mds) = + braceBlock (map (prettyPrec p) mds) + +instance Pretty Decl where + prettyPrec p (MemberDecl md) = prettyPrec p md + prettyPrec p (InitDecl b bl) = + opt b (text "static") <+> prettyPrec p bl + +instance Pretty MemberDecl where + prettyPrec p (FieldDecl mods t vds) = + hsep (map (prettyPrec p) mods ++ prettyPrec p t:map (prettyPrec p) vds) <> semi + + prettyPrec p (MethodDecl mods tParams mt ident fParams throws body) = + hsep [hsep (map (prettyPrec p) mods) + , ppTypeParams p tParams + , ppResultType p mt + , prettyPrec p ident + , ppArgs p fParams + , ppThrows p throws + ] $$ prettyPrec p body + + prettyPrec p (ConstructorDecl mods tParams ident fParams throws body) = + hsep [hsep (map (prettyPrec p) mods) + , ppTypeParams p tParams + , prettyPrec p ident + , ppArgs p fParams + , ppThrows p throws + ] $$ prettyPrec p body + + prettyPrec p (MemberClassDecl cd) = prettyPrec p cd + prettyPrec p (MemberInterfaceDecl id) = prettyPrec p id + +instance Pretty VarDecl where + prettyPrec p (VarDecl vdId Nothing) = prettyPrec p vdId + prettyPrec p (VarDecl vdId (Just ie)) = + (prettyPrec p vdId <+> char '=') <+> prettyPrec p ie + +instance Pretty VarDeclId where + prettyPrec p (VarId ident) = prettyPrec p ident + prettyPrec p (VarDeclArray vId) = prettyPrec p vId + +instance Pretty VarInit where + prettyPrec p (InitExp e) = prettyPrec p e + prettyPrec p (InitArray (ArrayInit ai)) = + text "{" <+> hsep (punctuate comma (map (prettyPrec p) ai)) <+> text "}" + +instance Pretty FormalParam where + prettyPrec p (FormalParam mods t b vId) = + hsep [hsep (map (prettyPrec p) mods) + , prettyPrec p t <> opt b (text "...") + , prettyPrec p vId + ] + +instance Pretty MethodBody where + prettyPrec p (MethodBody mBlock) = maybe semi (prettyPrec p) mBlock + +instance Pretty ConstructorBody where + prettyPrec p (ConstructorBody mECI stmts) = + braceBlock $ maybePP p mECI : map (prettyPrec p) stmts + +instance Pretty ExplConstrInv where + prettyPrec p (ThisInvoke rts args) = + ppTypeParams p rts <+> text "this" <> ppArgs p args <> semi + prettyPrec p (SuperInvoke rts args) = + ppTypeParams p rts <+> text "super" <> ppArgs p args <> semi + prettyPrec p (PrimarySuperInvoke e rts args) = + prettyPrec p e <> char '.' <> + ppTypeParams p rts <+> text "super" <> ppArgs p args <> semi + +instance Pretty Modifier where + prettyPrec p (Annotation ann) = prettyPrec p ann $+$ nest (-1) ( text "") + prettyPrec p mod = text . map toLower $ show mod + +instance Pretty Annotation where + prettyPrec p x = text "@" <> prettyPrec p (annName x) <> case x of + MarkerAnnotation {} -> text "" + SingleElementAnnotation {} -> text "(" <> prettyPrec p (annValue x) <> text ")" + NormalAnnotation {} -> text "(" <> ppEVList p (annKV x) <> text ")" + +ppEVList p = hsep . punctuate comma . map (\(k,v) -> prettyPrec p k <+> text "=" <+> prettyPrec p v) + +instance Pretty ElementValue where + prettyPrec p (EVVal vi) = prettyPrec p vi + prettyPrec p (EVAnn ann) = prettyPrec p ann + +----------------------------------------------------------------------- +-- Statements + + +instance Pretty Block where + prettyPrec p (Block stmts) = braceBlock $ map (prettyPrec p) stmts + +instance Pretty BlockStmt where + prettyPrec p (BlockStmt stmt) = prettyPrec p stmt + prettyPrec p (LocalClass cd) = prettyPrec p cd + prettyPrec p (LocalVars mods t vds) = + hsep (map (prettyPrec p) mods) <+> prettyPrec p t <+> + hsep (punctuate comma $ map (prettyPrec p) vds) <> semi + +instance Pretty Stmt where + prettyPrec p (StmtBlock block) = prettyPrec p block + prettyPrec p (IfThen c th) = + text "if" <+> parens (prettyPrec 0 c) $+$ prettyNestedStmt 0 th + + prettyPrec p (IfThenElse c th el) = + text "if" <+> parens (prettyPrec p c) $+$ prettyNestedStmt 0 th $+$ text "else" $+$ prettyNestedStmt 0 el + + prettyPrec p (While c stmt) = + text "while" <+> parens (prettyPrec p c) $+$ prettyNestedStmt 0 stmt + + prettyPrec p (BasicFor mInit mE mUp stmt) = + text "for" <+> (parens $ hsep [maybePP p mInit, semi + , maybePP p mE, semi + , maybe empty (hsep . punctuate comma . map (prettyPrec p)) mUp + ]) $+$ prettyNestedStmt p stmt + + prettyPrec p (EnhancedFor mods t ident e stmt) = + hsep [text "for" + , parens $ hsep [ + hsep (map (prettyPrec p) mods) + , prettyPrec p t + , prettyPrec p ident + , colon + , prettyPrec p e + ] + , prettyPrec p stmt + ] + + prettyPrec p Empty = semi + + prettyPrec p (ExpStmt e) = prettyPrec p e <> semi + + prettyPrec p (Assert ass mE) = + text "assert" <+> prettyPrec p ass + <+> maybe empty ((colon <>) . prettyPrec p) mE <> semi + + prettyPrec p (Switch e sBlocks) = + text "switch" <+> parens (prettyPrec p e) + $$ braceBlock (map (prettyPrec p) sBlocks) + + prettyPrec p (Do stmt e) = + text "do" $+$ prettyPrec p stmt <+> text "while" <+> parens (prettyPrec p e) <> semi + + prettyPrec p (Break mIdent) = + text "break" <+> maybePP p mIdent <> semi + + prettyPrec p (Continue mIdent) = + text "continue" <+> maybePP p mIdent <> semi + + prettyPrec p (Return mE) = + text "return" <+> maybePP p mE <> semi + + prettyPrec p (Synchronized e block) = + text "synchronized" <+> parens (prettyPrec p e) $$ prettyPrec p block + + prettyPrec p (Throw e) = + text "throw" <+> prettyPrec p e <> semi + + prettyPrec p (Try block catches mFinally) = + text "try" $$ prettyPrec p block $$ + vcat (map (prettyPrec p) catches ++ [ppFinally mFinally]) + where ppFinally Nothing = empty + ppFinally (Just bl) = text "finally" <+> prettyPrec p bl + + prettyPrec p (Labeled ident stmt) = + prettyPrec p ident <> colon <+> prettyPrec p stmt + +instance Pretty Catch where + prettyPrec p (Catch fParam block) = + hsep [text "catch", parens (prettyPrec p fParam)] $$ prettyPrec p block + +instance Pretty SwitchBlock where + prettyPrec p (SwitchBlock lbl stmts) = + vcat (prettyPrec p lbl : map (nest 2 . prettyPrec p) stmts) + +instance Pretty SwitchLabel where + prettyPrec p (SwitchCase e) = + text "case" <+> prettyPrec p e <> colon + prettyPrec p Default = text "default:" + +instance Pretty ForInit where + prettyPrec p (ForLocalVars mods t vds) = + hsep $ map (prettyPrec p) mods ++ + prettyPrec p t: punctuate comma (map (prettyPrec p) vds) + prettyPrec p (ForInitExps es) = + hsep $ punctuate comma (map (prettyPrec p) es) + + +----------------------------------------------------------------------- +-- Expressions + +instance Pretty Exp where + prettyPrec p (Lit l) = prettyPrec p l + + prettyPrec p (ClassLit mT) = + ppResultType p mT <> text ".class" + + prettyPrec _ This = text "this" + + prettyPrec p (ThisClass name) = + prettyPrec p name <> text ".this" + + prettyPrec p (InstanceCreation tArgs ct args mBody) = + hsep [text "new" + , ppTypeParams p tArgs + , prettyPrec p ct <> ppArgs p args + ] $$ maybePP p mBody + + prettyPrec p (QualInstanceCreation e tArgs ident args mBody) = + hsep [prettyPrec p e <> char '.' <> text "new" + , ppTypeParams p tArgs + , prettyPrec p ident <> ppArgs p args + ] $$ maybePP p mBody + + prettyPrec p (ArrayCreate t es k) = + text "new" <+> + hcat (prettyPrec p t : map (brackets . prettyPrec p) es + ++ replicate k (text "[]")) + + prettyPrec p (ArrayCreateInit t k init) = + text "new" + <+> hcat (prettyPrec p t : replicate k (text "[]")) + <+> prettyPrec p init + + prettyPrec p (FieldAccess fa) = parenPrec p 1 $ prettyPrec 1 fa + + prettyPrec p (MethodInv mi) = parenPrec p 1 $ prettyPrec 1 mi + + prettyPrec p (ArrayAccess ain) = parenPrec p 1 $ prettyPrec 1 ain + + prettyPrec p (ExpName name) = prettyPrec p name + + prettyPrec p (PostIncrement e) = parenPrec p 2 $ prettyPrec 2 e <> text "++" + + prettyPrec p (PostDecrement e) = parenPrec p 2 $ prettyPrec 2 e <> text "--" + + prettyPrec p (PreIncrement e) = parenPrec p 2 $ text "++" <> prettyPrec 2 e + + prettyPrec p (PreDecrement e) = parenPrec p 2 $ text "--" <> prettyPrec 2 e + + prettyPrec p (PrePlus e) = parenPrec p 2 $ char '+' <> prettyPrec 2 e + + prettyPrec p (PreMinus e) = parenPrec p 2 $ char '-' <> prettyPrec 2 e + + prettyPrec p (PreBitCompl e) = parenPrec p 2 $ char '~' <> prettyPrec 2 e + + prettyPrec p (PreNot e) = parenPrec p 2 $ char '!' <> prettyPrec 2 e + + prettyPrec p (Cast t e) = parenPrec p 2 $ parens (prettyPrec p t) <+> prettyPrec 2 e + + prettyPrec p (BinOp e1 op e2) = + let prec = opPrec op in + parenPrec p prec (prettyPrec prec e1 <+> prettyPrec p op <+> prettyPrec prec e2) + + prettyPrec p (InstanceOf e rt) = + let cp = opPrec LThan in + parenPrec p cp $ prettyPrec cp e + <+> text "instanceof" <+> prettyPrec cp rt + + prettyPrec p (Cond c th el) = + parenPrec p 13 $ prettyPrec 13 c <+> char '?' + <+> prettyPrec p th <+> colon <+> prettyPrec 13 el + + prettyPrec p (Assign lhs aop e) = + hsep [prettyPrec p lhs, prettyPrec p aop, prettyPrec p e] + + +instance Pretty Literal where + prettyPrec p (Int i) = text (show i) + prettyPrec p (Word i) = text (show i) <> char 'L' + prettyPrec p (Float f) = text (show f) <> char 'F' + prettyPrec p (Double d) = text (show d) + prettyPrec p (Boolean b) = text . map toLower $ show b + prettyPrec p (Char c) = text (show c) + prettyPrec p (String s) = text (show s) + prettyPrec p (Null) = text "null" + +instance Pretty Op where + prettyPrec p op = text $ case op of + Mult -> "*" + Div -> "/" + Rem -> "%" + Add -> "+" + Sub -> "-" + LShift -> "<<" + RShift -> ">>" + RRShift -> ">>>" + LThan -> "<" + GThan -> ">" + LThanE -> "<=" + GThanE -> ">=" + Equal -> "==" + NotEq -> "!=" + And -> "&" + Xor -> "^" + Or -> "|" + CAnd -> "&&" + COr -> "||" + +instance Pretty AssignOp where + prettyPrec p aop = text $ case aop of + EqualA -> "=" + MultA -> "*=" + DivA -> "/=" + RemA -> "%=" + AddA -> "+=" + SubA -> "-=" + LShiftA -> "<<=" + RShiftA -> ">>=" + RRShiftA -> ">>>=" + AndA -> "&=" + XorA -> "^=" + OrA -> "|=" + +instance Pretty Lhs where + prettyPrec p (NameLhs name) = prettyPrec p name + prettyPrec p (FieldLhs fa) = prettyPrec p fa + prettyPrec p (ArrayLhs ain) = prettyPrec p ain + +instance Pretty ArrayIndex where + prettyPrec p (ArrayIndex ref e) = prettyPrec p ref <> brackets (prettyPrec p e) + +instance Pretty FieldAccess where + prettyPrec p (PrimaryFieldAccess e ident) = + prettyPrec p e <> char '.' <> prettyPrec p ident + prettyPrec p (SuperFieldAccess ident) = + text "super." <> prettyPrec p ident + prettyPrec p (ClassFieldAccess name ident) = + prettyPrec p name <> text ".super." <> prettyPrec p ident + +instance Pretty MethodInvocation where + prettyPrec p (MethodCall name args) = + prettyPrec p name <> ppArgs p args + + prettyPrec p (PrimaryMethodCall e tArgs ident args) = + hcat [prettyPrec p e, char '.', ppTypeParams p tArgs, + prettyPrec p ident, ppArgs p args] + + prettyPrec p (SuperMethodCall tArgs ident args) = + hcat [text "super.", ppTypeParams p tArgs, + prettyPrec p ident, ppArgs p args] + + prettyPrec p (ClassMethodCall name tArgs ident args) = + hcat [prettyPrec p name, text ".super.", ppTypeParams p tArgs, + prettyPrec p ident, ppArgs p args] + + prettyPrec p (TypeMethodCall name tArgs ident args) = + hcat [prettyPrec p name, char '.', ppTypeParams p tArgs, + prettyPrec p ident, ppArgs p args] + +instance Pretty ArrayInit where + prettyPrec p (ArrayInit vInits) = + braceBlock $ map (\v -> prettyPrec p v <> comma) vInits + --braces $ hsep (punctuate comma (map (prettyPrec p) vInits)) + + +ppArgs :: Pretty a => Int -> [a] -> Doc +ppArgs p = parens . hsep . punctuate comma . map (prettyPrec p) + +----------------------------------------------------------------------- +-- Types + +instance Pretty Type where + prettyPrec p (PrimType pt) = prettyPrec p pt + prettyPrec p (RefType rt) = prettyPrec p rt + +instance Pretty RefType where + prettyPrec p (ClassRefType ct) = prettyPrec p ct + prettyPrec p (ArrayType t) = prettyPrec p t <> text "[]" + +instance Pretty ClassType where + prettyPrec p (ClassType itas) = + hcat . punctuate (char '.') $ + map (\(i,tas) -> prettyPrec p i <> ppTypeParams p tas) itas + +instance Pretty TypeArgument where + prettyPrec p (ActualType rt) = prettyPrec p rt + prettyPrec p (Wildcard mBound) = char '?' <+> maybePP p mBound + +instance Pretty WildcardBound where + prettyPrec p (ExtendsBound rt) = text "extends" <+> prettyPrec p rt + prettyPrec p (SuperBound rt) = text "super" <+> prettyPrec p rt + +instance Pretty PrimType where + prettyPrec p BooleanT = text "boolean" + prettyPrec p ByteT = text "byte" + prettyPrec p ShortT = text "short" + prettyPrec p IntT = text "int" + prettyPrec p LongT = text "long" + prettyPrec p CharT = text "char" + prettyPrec p FloatT = text "float" + prettyPrec p DoubleT = text "double" + +instance Pretty TypeParam where + prettyPrec p (TypeParam ident rts) = + prettyPrec p ident + <+> opt (not $ null rts) + (hsep $ text "extends": + punctuate (text " &") (map (prettyPrec p) rts)) + +ppTypeParams :: Pretty a => Int -> [a] -> Doc +ppTypeParams _ [] = empty +ppTypeParams p tps = char '<' + <> hsep (punctuate comma (map (prettyPrec p) tps)) + <> char '>' + +ppImplements :: Int -> [RefType] -> Doc +ppImplements _ [] = empty +ppImplements p rts = text "implements" + <+> hsep (punctuate comma (map (prettyPrec p) rts)) + +ppExtends :: Int -> [RefType] -> Doc +ppExtends _ [] = empty +ppExtends p rts = text "extends" + <+> hsep (punctuate comma (map (prettyPrec p) rts)) + +ppThrows :: Int -> [ExceptionType] -> Doc +ppThrows _ [] = empty +ppThrows p ets = text "throws" + <+> hsep (punctuate comma (map (prettyPrec p) ets)) + +ppResultType :: Int -> Maybe Type -> Doc +ppResultType _ Nothing = text "void" +ppResultType p (Just a) = prettyPrec p a + +----------------------------------------------------------------------- +-- Names and identifiers + +instance Pretty Name where + prettyPrec p (Name is) = + hcat (punctuate (char '.') $ map (prettyPrec p) is) + +instance Pretty Ident where + prettyPrec p (Ident s) = text s + + +----------------------------------------------------------------------- +-- Help functionality +prettyNestedStmt :: Int -> Stmt -> Doc +prettyNestedStmt prio p@(StmtBlock b) = prettyPrec prio p +prettyNestedStmt prio p = nest 2 (prettyPrec prio p) + +maybePP :: Pretty a => Int -> Maybe a -> Doc +maybePP p = maybe empty (prettyPrec p) + +opt :: Bool -> Doc -> Doc +opt x a = if x then a else empty + +braceBlock :: [Doc] -> Doc +braceBlock xs = char '{' + $+$ nest 2 (vcat xs) + $+$ char '}' + +opPrec Mult = 3 +opPrec Div = 3 +opPrec Rem = 3 +opPrec Add = 4 +opPrec Sub = 4 +opPrec LShift = 5 +opPrec RShift = 5 +opPrec RRShift = 5 +opPrec LThan = 6 +opPrec GThan = 6 +opPrec LThanE = 6 +opPrec GThanE = 6 +opPrec Equal = 7 +opPrec NotEq = 7 +opPrec And = 8 +opPrec Xor = 9 +opPrec Or = 10 +opPrec CAnd = 11 +opPrec COr = 12 diff --git a/dist/build/Language/Java/Lexer.hs b/dist/build/Language/Java/Lexer.hs --- a/dist/build/Language/Java/Lexer.hs +++ b/dist/build/Language/Java/Lexer.hs @@ -1,14 +1,14 @@ {-# LANGUAGE CPP,MagicHash #-} {-# LINE 1 "Language/Java/Lexer.x" #-} - -{-# LANGUAGE BangPatterns #-} -module Language.Java.Lexer (L(..), Token(..), lexer) where - -import Numeric -import Data.Char - -import Debug.Trace (trace) +{-# LANGUAGE BangPatterns #-} +module Language.Java.Lexer (L(..), Token(..), lexer) where + +import Numeric +import Data.Char + +import Debug.Trace (trace) + #if __GLASGOW_HASKELL__ >= 603 #include "ghcconfig.h" #elif defined(__GLASGOW_HASKELL__) @@ -187,206 +187,206 @@ alex_accept = listArray (0::Int,381) [[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_16))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_26))],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_29))],[(AlexAcc (alex_action_30))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_32))],[(AlexAcc (alex_action_33))],[(AlexAcc (alex_action_34))],[(AlexAcc (alex_action_35))],[(AlexAcc (alex_action_36))],[(AlexAcc (alex_action_37))],[(AlexAcc (alex_action_38))],[(AlexAcc (alex_action_39))],[(AlexAcc (alex_action_40))],[(AlexAcc (alex_action_41))],[(AlexAcc (alex_action_42))],[(AlexAcc (alex_action_43))],[(AlexAcc (alex_action_44))],[(AlexAcc (alex_action_45))],[(AlexAcc (alex_action_46))],[(AlexAcc (alex_action_47))],[(AlexAcc (alex_action_48))],[(AlexAcc (alex_action_49))],[(AlexAcc (alex_action_50))],[(AlexAcc (alex_action_51))],[(AlexAcc (alex_action_52))],[(AlexAcc (alex_action_53))],[(AlexAcc (alex_action_54))],[(AlexAcc (alex_action_55))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_57))],[(AlexAcc (alex_action_58))],[(AlexAcc (alex_action_59))],[(AlexAcc (alex_action_60))],[(AlexAcc (alex_action_60))],[(AlexAcc (alex_action_60))],[(AlexAcc (alex_action_61))],[(AlexAcc (alex_action_61))],[(AlexAcc (alex_action_61))],[(AlexAcc (alex_action_62))],[(AlexAcc (alex_action_63))],[(AlexAcc (alex_action_64))],[(AlexAcc (alex_action_65))],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_69))],[(AlexAcc (alex_action_70))],[(AlexAcc (alex_action_71))],[(AlexAcc (alex_action_72))],[(AlexAcc (alex_action_73))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_75))],[(AlexAcc (alex_action_76))],[(AlexAcc (alex_action_77))],[(AlexAcc (alex_action_78))],[(AlexAcc (alex_action_79))],[(AlexAcc (alex_action_80))],[(AlexAcc (alex_action_81))],[(AlexAcc (alex_action_82))],[(AlexAcc (alex_action_83))],[(AlexAcc (alex_action_84))],[(AlexAcc (alex_action_85))],[(AlexAcc (alex_action_86))],[(AlexAcc (alex_action_87))],[(AlexAcc (alex_action_88))],[(AlexAcc (alex_action_89))],[(AlexAcc (alex_action_90))],[(AlexAcc (alex_action_91))],[(AlexAcc (alex_action_92))],[(AlexAcc (alex_action_93))],[(AlexAcc (alex_action_94))],[(AlexAcc (alex_action_95))],[(AlexAcc (alex_action_96))],[(AlexAcc (alex_action_97))],[(AlexAcc (alex_action_98))],[(AlexAcc (alex_action_99))],[(AlexAcc (alex_action_100))],[(AlexAcc (alex_action_101))],[(AlexAcc (alex_action_102))],[(AlexAcc (alex_action_103))],[(AlexAcc (alex_action_104))],[(AlexAcc (alex_action_105))],[(AlexAcc (alex_action_106))],[(AlexAcc (alex_action_107))],[(AlexAcc (alex_action_108))],[(AlexAcc (alex_action_109))],[(AlexAcc (alex_action_110))],[(AlexAcc (alex_action_111))],[(AlexAcc (alex_action_112))],[(AlexAcc (alex_action_113))],[(AlexAcc (alex_action_114))],[(AlexAcc (alex_action_115))],[(AlexAcc (alex_action_116))],[(AlexAcc (alex_action_117))],[(AlexAcc (alex_action_118))],[(AlexAcc (alex_action_119))],[(AlexAcc (alex_action_120))],[(AlexAcc (alex_action_121))]] {-# LINE 173 "Language/Java/Lexer.x" #-} - - -pickyReadOct :: String -> Integer -pickyReadOct s = - if not $ null rem - then lexicalError $ "Non-octal digit '" ++ take 1 rem ++ "' in \"" ++ s ++ "\"." - else n - where (n,rem) = head $ readOct s - -readHexExp :: (Floating a, Eq a) => String -> a -readHexExp s = let (m, suf) = head $ readHex s - (e, _) = case suf of - p:s | toLower p == 'p' -> head $ readHex s - _ -> (0, "") - in m ** e - -readCharTok :: String -> Char -readCharTok s = head . convChar . dropQuotes $ s -readStringTok :: String -> String -readStringTok = convChar . dropQuotes - -dropQuotes :: String -> String -dropQuotes s = take (length s - 2) (tail s) - --- Converts a sequence of (unquoted) Java character literals, including --- escapes, into the sequence of corresponding Chars. The calls to --- 'lexicalError' double-check that this function is consistent with --- the lexer rules for character and string literals. This function --- could be expressed as another Alex lexer, but it's simple enough --- to implement by hand. -convChar :: String -> String -convChar ('\\':'u':s@(d1:d2:d3:d4:s')) = - -- TODO: this is the wrong place for handling unicode escapes - -- according to the Java Language Specification. Unicode escapes can - -- appear anywhere in the source text, and are best processed - -- before lexing. - if all isHexDigit [d1,d2,d3,d4] - then toEnum (read ['0','x',d1,d2,d3,d4]):convChar s' - else lexicalError $ "bad unicode escape \"\\u" ++ take 4 s ++ "\"" -convChar ('\\':'u':s) = - lexicalError $ "bad unicode escape \"\\u" ++ take 4 s ++ "\"" -convChar ('\\':c:s) = - if isOctDigit c - then convOctal maxRemainingOctals - else (case c of - 'b' -> '\b' - 'f' -> '\f' - 'n' -> '\n' - 'r' -> '\r' - 't' -> '\t' - '\'' -> '\'' - '\\' -> '\\' - '"' -> '"' - _ -> badEscape):convChar s - where maxRemainingOctals = - if c <= '3' then 2 else 1 - convOctal n = - let octals = takeWhile isOctDigit $ take n s - noctals = length octals - toChar = toEnum . fst . head . readOct - in toChar (c:octals):convChar (drop noctals s) - badEscape = lexicalError $ "bad escape \"\\" ++ c:"\"" -convChar ("\\") = - lexicalError "bad escape \"\\\"" -convChar (x:s) = x:convChar s -convChar "" = "" - -lexicalError :: String -> a -lexicalError = error . ("lexical error: " ++) - -data L a = L Pos a - deriving (Show, Eq) - --- (line, column) -type Pos = (Int, Int) - -pos :: AlexPosn -> Pos -pos (AlexPn _ l c) = (l,c) - -data Token - -- Keywords - = KW_Abstract - | KW_Assert - | KW_Boolean - | KW_Break - | KW_Byte - | KW_Case - | KW_Catch - | KW_Char - | KW_Class - | KW_Const - | KW_Continue - | KW_Default - | KW_Do - | KW_Double - | KW_Else - | KW_Enum - | KW_Extends - | KW_Final - | KW_Finally - | KW_Float - | KW_For - | KW_Goto - | KW_If - | KW_Implements - | KW_Import - | KW_Instanceof - | KW_Int - | KW_Interface - | KW_Long - | KW_Native - | KW_New - | KW_Package - | KW_Private - | KW_Protected - | KW_Public - | KW_Return - | KW_Short - | KW_Static - | KW_Strictfp - | KW_Super - | KW_Switch - | KW_Synchronized - | KW_This - | KW_Throw - | KW_Throws - | KW_Transient - | KW_Try - | KW_Void - | KW_Volatile - | KW_While - - -- Separators - | OpenParen - | CloseParen - | OpenSquare - | CloseSquare - | OpenCurly - | CloseCurly - | SemiColon - | Comma - | Period - - -- Literals - | IntTok Integer - | LongTok Integer - | DoubleTok Double - | FloatTok Double - | CharTok Char - | StringTok String - | BoolTok Bool - | NullTok - - -- Identifiers - | IdentTok String - - -- Operators - | Op_Equal - | Op_GThan - | Op_LThan - | Op_Bang - | Op_Tilde - | Op_Query - | Op_Colon - | Op_Equals - | Op_LThanE - | Op_GThanE - | Op_BangE - | Op_AAnd - | Op_OOr - | Op_PPlus - | Op_MMinus - | Op_Plus - | Op_Minus - | Op_Star - | Op_Slash - | Op_And - | Op_Or - | Op_Caret - | Op_Percent - | Op_LShift - | Op_RShift - | Op_RRShift - | Op_PlusE - | Op_MinusE - | Op_StarE - | Op_SlashE - | Op_AndE - | Op_OrE - | Op_CaretE - | Op_PercentE - | Op_LShiftE - | Op_RShiftE - | Op_RRShiftE - | Op_AtSign - deriving (Show, Eq) - -lexer :: String -> [L Token] -lexer = alexScanTokens - + + +pickyReadOct :: String -> Integer +pickyReadOct s = + if not $ null rem + then lexicalError $ "Non-octal digit '" ++ take 1 rem ++ "' in \"" ++ s ++ "\"." + else n + where (n,rem) = head $ readOct s + +readHexExp :: (Floating a, Eq a) => String -> a +readHexExp s = let (m, suf) = head $ readHex s + (e, _) = case suf of + p:s | toLower p == 'p' -> head $ readHex s + _ -> (0, "") + in m ** e + +readCharTok :: String -> Char +readCharTok s = head . convChar . dropQuotes $ s +readStringTok :: String -> String +readStringTok = convChar . dropQuotes + +dropQuotes :: String -> String +dropQuotes s = take (length s - 2) (tail s) + +-- Converts a sequence of (unquoted) Java character literals, including +-- escapes, into the sequence of corresponding Chars. The calls to +-- 'lexicalError' double-check that this function is consistent with +-- the lexer rules for character and string literals. This function +-- could be expressed as another Alex lexer, but it's simple enough +-- to implement by hand. +convChar :: String -> String +convChar ('\\':'u':s@(d1:d2:d3:d4:s')) = + -- TODO: this is the wrong place for handling unicode escapes + -- according to the Java Language Specification. Unicode escapes can + -- appear anywhere in the source text, and are best processed + -- before lexing. + if all isHexDigit [d1,d2,d3,d4] + then toEnum (read ['0','x',d1,d2,d3,d4]):convChar s' + else lexicalError $ "bad unicode escape \"\\u" ++ take 4 s ++ "\"" +convChar ('\\':'u':s) = + lexicalError $ "bad unicode escape \"\\u" ++ take 4 s ++ "\"" +convChar ('\\':c:s) = + if isOctDigit c + then convOctal maxRemainingOctals + else (case c of + 'b' -> '\b' + 'f' -> '\f' + 'n' -> '\n' + 'r' -> '\r' + 't' -> '\t' + '\'' -> '\'' + '\\' -> '\\' + '"' -> '"' + _ -> badEscape):convChar s + where maxRemainingOctals = + if c <= '3' then 2 else 1 + convOctal n = + let octals = takeWhile isOctDigit $ take n s + noctals = length octals + toChar = toEnum . fst . head . readOct + in toChar (c:octals):convChar (drop noctals s) + badEscape = lexicalError $ "bad escape \"\\" ++ c:"\"" +convChar ("\\") = + lexicalError "bad escape \"\\\"" +convChar (x:s) = x:convChar s +convChar "" = "" + +lexicalError :: String -> a +lexicalError = error . ("lexical error: " ++) + +data L a = L Pos a + deriving (Show, Eq) + +-- (line, column) +type Pos = (Int, Int) + +pos :: AlexPosn -> Pos +pos (AlexPn _ l c) = (l,c) + +data Token + -- Keywords + = KW_Abstract + | KW_Assert + | KW_Boolean + | KW_Break + | KW_Byte + | KW_Case + | KW_Catch + | KW_Char + | KW_Class + | KW_Const + | KW_Continue + | KW_Default + | KW_Do + | KW_Double + | KW_Else + | KW_Enum + | KW_Extends + | KW_Final + | KW_Finally + | KW_Float + | KW_For + | KW_Goto + | KW_If + | KW_Implements + | KW_Import + | KW_Instanceof + | KW_Int + | KW_Interface + | KW_Long + | KW_Native + | KW_New + | KW_Package + | KW_Private + | KW_Protected + | KW_Public + | KW_Return + | KW_Short + | KW_Static + | KW_Strictfp + | KW_Super + | KW_Switch + | KW_Synchronized + | KW_This + | KW_Throw + | KW_Throws + | KW_Transient + | KW_Try + | KW_Void + | KW_Volatile + | KW_While + + -- Separators + | OpenParen + | CloseParen + | OpenSquare + | CloseSquare + | OpenCurly + | CloseCurly + | SemiColon + | Comma + | Period + + -- Literals + | IntTok Integer + | LongTok Integer + | DoubleTok Double + | FloatTok Double + | CharTok Char + | StringTok String + | BoolTok Bool + | NullTok + + -- Identifiers + | IdentTok String + + -- Operators + | Op_Equal + | Op_GThan + | Op_LThan + | Op_Bang + | Op_Tilde + | Op_Query + | Op_Colon + | Op_Equals + | Op_LThanE + | Op_GThanE + | Op_BangE + | Op_AAnd + | Op_OOr + | Op_PPlus + | Op_MMinus + | Op_Plus + | Op_Minus + | Op_Star + | Op_Slash + | Op_And + | Op_Or + | Op_Caret + | Op_Percent + | Op_LShift + | Op_RShift + | Op_RRShift + | Op_PlusE + | Op_MinusE + | Op_StarE + | Op_SlashE + | Op_AndE + | Op_OrE + | Op_CaretE + | Op_PercentE + | Op_LShiftE + | Op_RShiftE + | Op_RRShiftE + | Op_AtSign + deriving (Show, Eq) + +lexer :: String -> [L Token] +lexer = alexScanTokens + alex_action_2 = \p _ -> L (pos p) $ KW_Abstract alex_action_3 = \p _ -> L (pos p) $ KW_Assert diff --git a/language-java.cabal b/language-java.cabal --- a/language-java.cabal +++ b/language-java.cabal @@ -1,5 +1,5 @@ Name: language-java -Version: 0.2.1 +Version: 0.2.2 License: BSD3 License-File: LICENSE Author: Niklas Broberg