Wrote some files

javahc.cabal

@@ -22,9 +22,15 @@ library
       ClassTypeParameter
       JavaClass
       JavaClassAccess
+      JavaClassField
+      JavaClassFieldVisibility
       JavaClassModifier
+      JavaExpression
       JavaFile
+      JavaLanguage
+      JavaVariableInitializer
       Lib
+      LiteralExpression
       PrimitiveTypes
       Syntax
   other-modules:

src/Annotation.hs

@@ -0,0 +1,8 @@
+module Annotation (Annotation(..) )
+where
+
+import JavaExpression (JavaExpression)
+
+import Data.Map (Map)
+
+data Annotation = Normal String (Map String JavaExpression)

src/ClassLiteral.hs

@@ -0,0 +1,31 @@
+module ClassLiteral (ClassLiteral(..), parseClassLiteral ) where
+
+import qualified Data.List as List
+import Numeric.Natural (Natural)
+
+import PrimitiveTypes (PrimitiveType, primitiveType)
+import JavaLanguage (m_reserved, m_lexeme, m_identifier)
+
+import Text.Parsec (choice, string', many, sepBy, char, manyTill, lookAhead)
+import Text.Parsec.String (Parser)
+
+data ClassLiteral = Void 
+        | Primitive PrimitiveType Natural -- type, array dimension
+        | Type String Natural -- type, array dimension
+        deriving Show
+
+parseClassLiteral :: Parser ClassLiteral
+parseClassLiteral = choice 
+        [ m_reserved "void" *>  return Void
+        , primitiveType     >>= parseArrayDims . Primitive
+        , typeName          >>= parseArrayDims . Type
+        ] <* string' ".class"
+
+typeName :: Parser String
+typeName = do
+        start <- m_identifier
+        paths <- manyTill (char '.' *> m_identifier) (choice [ lookAhead $ string' ".class" , lookAhead $ string' "[]" ])
+        return . List.intercalate "." $ (start:paths)
+
+parseArrayDims :: (Natural -> ClassLiteral) -> Parser ClassLiteral
+parseArrayDims f = m_lexeme $ many (string' "[]") >>= return . f . fromInteger . toInteger . List.length

src/JavaClass.hs

@@ -14,5 +14,7 @@ data JavaClass = JavaClass { name       :: String
         , isAbstract                    :: Bool
         , typeParameters                :: [ClassTypeParameter]
         , extends                       :: Maybe ClassType
+        , implements                    :: [ClassType]
+        , permits                       :: [String]
         }
         deriving Show

src/JavaClassField.hs

@@ -0,0 +1,28 @@
+module JavaClassField (module JavaClassField) where
+
+import JavaClassFieldVisibility (JavaClassFieldVisibility)
+import PrimitiveTypes (PrimitiveType)
+import ClassTypeParameter (ClassType, ArrayType)
+import JavaVariableInitializer (JavaVariableInitializer)
+
+import Data.Set (Set)
+
+data JavaClassField = JavaClassField { name :: String
+        , visiblity   :: JavaClassFieldVisibility
+        , modifiers   :: Set JavaClassFieldModifier
+        , type_       :: JavaClassFieldType
+        , initializer :: Maybe JavaVariableInitializer
+        }
+        deriving Show
+
+data JavaClassFieldModifier = Static 
+        | Final 
+        | Transient 
+        | Volatile
+        deriving (Show, Ord, Eq)
+
+data JavaClassFieldType = PrimitiveFieldType PrimitiveType 
+        | ClassFieldType ClassType 
+        | VariableFieldType String 
+        | ArrayFieldType ArrayType
+        deriving Show

src/JavaClassFieldVisibility.hs

@@ -0,0 +1,4 @@
+module JavaClassFieldVisibility (JavaClassFieldVisibility(..) ) where
+
+data JavaClassFieldVisibility = Public | Protected | Private | Package
+        deriving Show

src/JavaLanguage.hs

@@ -0,0 +1,65 @@
+module JavaLanguage 
+( javaLanguageDef
+, m_paren
+, m_identifier
+, m_reserved
+, m_lexeme
+, m_symbol
+, m_commaSep1
+, m_commaSep
+, m_angles
+, m_braces
+, m_reservedOp
+) where
+
+import Text.Parsec
+import Text.Parsec.Language
+import Text.Parsec.Token
+
+import Data.Functor.Identity
+
+javaLanguageDef :: GenLanguageDef String u Identity
+javaLanguageDef = emptyDef{ commentStart = "/*"
+              , commentEnd = "*/"
+              , commentLine = "//"
+              , nestedComments = False
+              , identStart = letter <|> char '_'
+              , identLetter = alphaNum <|> char '_'
+              , opStart = oneOf ".+-*/;"
+              , opLetter = oneOf ".+-*/;"
+              , reservedOpNames = [";"]
+              , reservedNames = [ "true"
+                , "false"
+                , "package"
+                , "class"
+                , "interface"
+                , "void"
+                , "boolean"
+                , "char"
+                , "short"
+                , "int"
+                , "float"
+                , "long"
+                , "double"
+                , "instanceof"
+                , "public"
+                , "private"
+                , "protected"
+                , "static"
+                , "final"
+                , "volatile"
+                , "transient"
+                ]
+              , caseSensitive = True
+              }
+
+TokenParser{ parens = m_paren
+        , identifier = m_identifier 
+        , reserved   = m_reserved
+        , lexeme     = m_lexeme
+        , symbol     = m_symbol
+        , commaSep1  = m_commaSep1
+        , commaSep   = m_commaSep
+        , angles     = m_angles
+        , braces     = m_braces
+        , reservedOp = m_reservedOp } = makeTokenParser javaLanguageDef

src/JavaVariableInitializer.hs

@@ -0,0 +1,7 @@
+module JavaVariableInitializer (JavaVariableInitializer(..) ) where
+
+import JavaExpression (JavaExpression)
+
+data JavaVariableInitializer = ArrayVariableInitializer [JavaVariableInitializer] 
+        | ExpressionVariableInitializer JavaExpression
+        deriving Show

src/LiteralExpression.hs

@@ -0,0 +1,140 @@
+module LiteralExpression (LiteralExpression(..))
+where
+
+import Data.Ratio ((%))
+import Data.Int (Int16)
+import qualified Data.Char as Char
+
+import JavaLanguage (m_lexeme, m_reserved)
+
+import Text.Parsec (many1, digit, oneOf, option, char, choice, many, try, satisfy, manyTill, string', endOfLine, space)
+import Text.Parsec.String (Parser)
+
+data LiteralExpression = NullLiteral
+        | IntegerLiteral   Integer  IntegerLiteralType
+        | FloatingLiteral  Rational DecimalLiteralType
+        | BooleanLiteral   Bool
+        | CharacterLiteral Char
+        | StringLiteral    String
+        | TextLiteral      String
+        deriving Show
+
+data IntegerLiteralType = IntLiteral    | LongLiteral
+        deriving Show
+data DecimalLiteralType = DoubleLiteral | FloatLiteral
+        deriving Show
+
+signedInteger :: Parser Integer
+signedInteger = do
+        signFactor <- option 1 (char '-' *> return (-1))
+        digits     <- many1 digit
+        return (signFactor * read digits)
+
+parseNullLiteral :: Parser LiteralExpression
+parseNullLiteral = m_reserved "null" *> return NullLiteral
+
+-- TODO: Hex, Oct, Bin
+parseDecimalIntegerLiteral :: Parser LiteralExpression
+parseDecimalIntegerLiteral = m_lexeme $ do
+        negative    <- option False (char '-' *> return True)
+        digitString <- many1 digit
+        literalType <- option IntLiteral (oneOf "Ll" *> return LongLiteral)
+        let positiveNumber = read digitString :: Integer
+        let number = (if (negative) then negate else id) positiveNumber
+        return (IntegerLiteral number literalType)
+
+-- TODO: Hex
+parseDecimalFloatingLiteral :: Parser LiteralExpression
+parseDecimalFloatingLiteral = do
+        prefix      <- option "0" $ many1 digit
+        _           <- option '.' (char '.')
+        suffix      <- many digit
+        exponent    <- option 0 (char 'e' *> signedInteger)
+        literalType <- option FloatLiteral $ choice [ 
+                  oneOf "fF" *> return FloatLiteral
+                , oneOf "dD" *> return DoubleLiteral
+                ]
+        let suffixLength = length suffix
+        let prefixPower  = 10 ^ suffixLength :: Integer
+        let iprefix = read prefix :: Integer
+        let isuffix = if (suffixLength == 0) then 0 else read suffix :: Integer
+        let exponentPower = (if exponent > 0 then 10 ^ exponent else 1) % (if exponent < 0 then 10^(-exponent) else 1)
+        let rational = ((iprefix * prefixPower + isuffix) % prefixPower) * exponentPower
+        return (FloatingLiteral rational literalType)
+
+
+parseBooleanLiteral :: Parser LiteralExpression
+parseBooleanLiteral = choice 
+        [ m_reserved "true"  *> return (BooleanLiteral True)
+        , m_reserved "false" *> return (BooleanLiteral False)
+        ]
+
+parseCharLiteral :: Parser LiteralExpression
+parseCharLiteral = (char '\'' *> choice [
+          parseEscapedChar
+        , satisfy (not . flip elem "'\\")
+        ] <* char '\'') >>= return . CharacterLiteral
+
+-- TODO: Support double line terminator
+parseEscapedChar :: Parser Char
+parseEscapedChar = char '\\' *> choice [
+          char 'b' *> return '\b'
+        , char 's' *> return ' '
+        , char 't' *> return '\t'
+        , char 'n' *> return '\n'
+        , char 'f' *> return '\f'
+        , char 'r' *> return '\r'
+        , char '"' *> return '"'
+        , char '\'' *> return '\''
+        , char '\\' *> return '\\'
+        , parseOctalEscapedChar
+        ]
+
+parseOctalEscapedChar :: Parser Char
+parseOctalEscapedChar = choice [
+          try $ tripleOctalEscapedChar
+        , try $ doubleOctalEscapedChar
+        ,       singleOctalEscapedChar
+        ]
+
+singleOctalEscapedChar :: Parser Char
+singleOctalEscapedChar = do
+        char1 <- oneOf "01234567"
+        let num1 = read [char1] :: Int
+        return . Char.chr $ num1
+
+doubleOctalEscapedChar :: Parser Char
+doubleOctalEscapedChar = do
+        char1 <- oneOf "01234567"
+        char2 <- oneOf "01234567"
+        let num1 = read [char1] :: Int
+        let num2 = read [char2] :: Int
+        let num = num2 + num1 * 8
+        return . Char.chr $ num
+
+tripleOctalEscapedChar :: Parser Char
+tripleOctalEscapedChar = do
+        char1 <- oneOf "0123"
+        char2 <- oneOf "01234567"
+        char3 <- oneOf "01234567"
+        let num1 = read [char1] :: Int
+        let num2 = read [char2] :: Int
+        let num3 = read [char3] :: Int
+        let num = num3 + num2 * 8 + num1 * 64
+        return . Char.chr $ num
+
+parseStringLiteral :: Parser LiteralExpression
+parseStringLiteral = do
+        _ <- char '"'
+        content <- manyTill (choice
+                [ parseEscapedChar
+                , satisfy (not . flip elem "\r\n\"\\")
+                ]) (char '"')
+        return (StringLiteral content)
+
+parseTextLiteral :: Parser LiteralExpression
+parseTextLiteral = do
+        _ <- string' "\"\"\""
+        _ <- space `manyTill` endOfLine
+        content <- (choice [ parseEscapedChar , satisfy (not . flip elem "\\") ] ) `manyTill` (string' "\"\"\"")
+        return . TextLiteral $ content

src/PrimaryExpression.hs

@@ -0,0 +1,26 @@
+module PrimaryExpression (PrimaryExpression(..) ) where
+
+import qualified Data.List as List
+
+import ClassLiteral (ClassLiteral)
+import JavaLanguage (m_identifier)
+import LiteralExpression (LiteralExpression)
+
+import Text.Parsec (manyTill, char, string')
+import Text.Parsec.String (Parser)
+
+data PrimaryExpression = Literal LiteralExpression
+        | ClassLiteral ClassLiteral
+        | This
+        | TypedThis String
+        | InstanceCreation
+        deriving Show
+
+parseThis :: Parser PrimaryExpression
+parseThis = string' "this" *> return This
+
+parseTypedThis :: Parser PrimaryExpression
+parseTypedThis = do
+        start <- m_identifier
+        paths <- manyTill (char '.' *> m_identifier) (string' ".this")
+        return . TypedThis . List.intercalate "." $ (start:paths)

src/PrimitiveTypes.hs

@@ -1,7 +1,25 @@
-module PrimitiveTypes (
 module PrimitiveTypes 
-        , PrimitiveType 
+        ( PrimitiveType(..)
+        , primitiveType
         ) where
 
+import JavaLanguage (m_reserved)
+
+import Text.Parsec (choice)
+import Text.Parsec.String (Parser)
+
 data PrimitiveType = PrimitiveBoolean | PrimitiveByte | PrimitiveShort | PrimitiveInt | PrimitiveLong | PrimitiveChar | PrimitiveFloat | PrimitiveDouble
         deriving Show
+
+primitiveType :: Parser PrimitiveType
+primitiveType = choice [ 
+          m_reserved "boolean" *> return PrimitiveTypes.PrimitiveBoolean
+        , m_reserved "byte"    *> return PrimitiveTypes.PrimitiveByte
+        , m_reserved "char"    *> return PrimitiveTypes.PrimitiveChar
+        , m_reserved "short"   *> return PrimitiveTypes.PrimitiveShort
+        , m_reserved "int"     *> return PrimitiveTypes.PrimitiveInt
+        , m_reserved "float"   *> return PrimitiveTypes.PrimitiveFloat
+        , m_reserved "long"    *> return PrimitiveTypes.PrimitiveLong
+        , m_reserved "double"  *> return PrimitiveTypes.PrimitiveDouble
+        ]
+

src/Syntax.hs

@@ -13,58 +13,17 @@ import qualified JavaClassAccess as JavaClassAccess
 import qualified JavaClassModifier as JavaClassModifier
 import qualified JavaFile as JavaFile
 import qualified ClassTypeParameter as ClassTypeParameter
+import qualified JavaClassFieldVisibility as JavaClassFieldVisibility
+import qualified JavaClassField as JavaClassField
 import PrimitiveTypes
+import JavaLanguage
 
-import Data.Functor.Identity
 import qualified Data.List as List
 import qualified Data.Maybe as Maybe
+import qualified Data.Set as Set
 
 import Numeric.Natural
 
-javaLanguageDef :: GenLanguageDef String u Identity
-javaLanguageDef = emptyDef{ commentStart = "/*"
-              , commentEnd = "*/"
-              , commentLine = "//"
-              , nestedComments = False
-              , identStart = letter <|> char '_'
-              , identLetter = alphaNum <|> char '_'
-              , opStart = oneOf ".+-*/;"
-              , opLetter = oneOf ".+-*/;"
-              , reservedOpNames = [";"]
-              , reservedNames = [ "true"
-                , "false"
-                , "package"
-                , "class"
-                , "interface"
-                , "void"
-                , "boolean"
-                , "char"
-                , "short"
-                , "int"
-                , "float"
-                , "long"
-                , "double"
-                , "instanceof"
-                , "public"
-                , "private"
-                , "protected"
-                , "static"
-                , "final"
-                , "volatile"
-                , "transient"
-                ]
-              , caseSensitive = True
-              }
-
-TokenParser{ parens = m_paren
-        , identifier = m_identifier 
-        , reserved   = m_reserved
-        , lexeme     = m_lexeme
-        , symbol     = m_symbol
-        , commaSep1  = m_commaSep1
-        , angles     = m_angles
-        , reservedOp = m_reservedOp } = makeTokenParser javaLanguageDef
-
 javaPathParser = m_identifier `sepBy1` (string ".")
 
 semicolon = (m_lexeme . char $ ';') <?> "semicolon"
@@ -128,20 +87,9 @@ arrayType = do
                 , classType >>= return . ClassTypeParameter.ClassArrayType
                 , typeIdentifier >>= return . ClassTypeParameter.VariableArrayType
                 ]
-        arrayDepth <- (many1 $ string "[]") >>= return . List.length
+        arrayDepth <- m_lexeme $ (many1 $ string "[]") >>= return . List.length
         return (partialConstructor (fromInteger . toInteger $ arrayDepth))
 
-primitiveType = choice [ 
-          m_reserved "boolean" *> return PrimitiveTypes.PrimitiveBoolean
-        , m_reserved "byte"    *> return PrimitiveTypes.PrimitiveByte
-        , m_reserved "char"    *> return PrimitiveTypes.PrimitiveChar
-        , m_reserved "short"   *> return PrimitiveTypes.PrimitiveShort
-        , m_reserved "int"     *> return PrimitiveTypes.PrimitiveInt
-        , m_reserved "float"   *> return PrimitiveTypes.PrimitiveFloat
-        , m_reserved "long"    *> return PrimitiveTypes.PrimitiveLong
-        , m_reserved "double"  *> return PrimitiveTypes.PrimitiveDouble
-        ]
-
 qualifiedClassType = do
         qualifiedType <- typeIdentifier `sepBy1` (string' ".") >>= return . List.intercalate "."
         maybeTypeArguments <- optionMaybe $ m_angles (m_commaSep1 typeArgument)
@@ -154,12 +102,13 @@ unqualifiedClassType = do
         let typeArguments = Maybe.fromMaybe [] maybeTypeArguments
         return (ClassTypeParameter.NonRecursiveTypeBound unqualifiedType typeArguments)
 
+-- TODO: Review this, i cancelled the left-recursive rule
 recursiveClassType = do
-        classType_ <- classType
-        _ <- char '.'
         unqualifiedType <- typeIdentifier
         maybeTypeArguments <- optionMaybe $ m_angles (m_commaSep1 typeArgument)
         let typeArguments = Maybe.fromMaybe [] maybeTypeArguments
+        _ <- char '.'
+        classType_ <- classType
         return (ClassTypeParameter.RecursiveTypeBound classType_ unqualifiedType typeArguments)
 
 classType = choice [ qualifiedClassType
@@ -169,13 +118,14 @@ classType = choice [ qualifiedClassType
 
 classTypeParameterClassOrInterfaceBound = do
         classType_ <- classType
-        interfaces <- m_commaSep1 interfaceType
+        interfaces <- m_commaSep interfaceType
         return (ClassTypeParameter.ClassTypeBound classType_ interfaces)
 
 classTypeParameterBound = do
         _ <- m_reserved' "extends"
-        bound <- choice [ typeIdentifier >>= return . ClassTypeParameter.SimpleTypeBound
-                , classTypeParameterClassOrInterfaceBound
+        bound <- choice [ 
+                  try classTypeParameterClassOrInterfaceBound
+                , typeIdentifier >>= return . ClassTypeParameter.SimpleTypeBound
                 ]
         return bound
 
@@ -185,17 +135,86 @@ classTypeParameter = do
         -- TODO: Interfaces
         return (ClassTypeParameter.ClassTypeParameter name typeBound [])
 
-classTypeParameters = optionMaybe $ m_angles $ (classTypeParameter `sepBy1` (m_symbol ","))
+classTypeParameters = optionMaybe $ m_angles $ ((classTypeParameter <?> "class type parameter") `sepBy1` (m_symbol ","))
+
+classPermits = do
+        _ <- m_reserved "permits"
+        m_commaSep typeName
+
+typeName = choice [
+          qualifiedTypeIdentifier
+        , typeIdentifier
+        ]
+
+qualifiedTypeIdentifier = do
+        packagePath <- many (try $ m_identifier <* char '.')
+        typeName_ <- typeIdentifier
+        return . List.intercalate "." $ packagePath ++ [typeName_]
+
+--classBody = many $ choice [
+--          classMemberDeclaration
+--        , classInstanceInitializer
+--        , classStaticInitializer
+--        , classConstructorDeclaration
+--        ]
+--  
+--classMemberDeclaration = choice [
+ --         classFieldDeclaration
+ --       , classMethodDeclaration
+ --       , classClassDeclaration
+ --       , classInterfaceDeclaration
+ --       ]
+ --
+
+-- TODO: Support multiple declarations
+classFieldDeclaration = do
+        visibility <- optionMaybe classFieldVisibility >>= return . Maybe.fromMaybe JavaClassFieldVisibility.Package
+        modifiers  <- many $ classFieldModifier
+        fieldType  <- classFieldType
+        let modifierSet = Set.fromList modifiers
+        -- TODO: throw errors for duplicates
+        -- TODO: Support declarator lists
+        fieldName  <- m_identifier
+ --       maybeInitializer <- optionMaybe $ m_reservedOp "=" *> variableInitializer
+        return $ JavaClassField.JavaClassField fieldName visibility modifierSet fieldType
+
+--variableInitializer = choice 
+--        [ 
+
+classFieldType = choice
+        [ arrayType      >>= return . JavaClassField.ArrayFieldType
+        , primitiveType  >>= return . JavaClassField.PrimitiveFieldType
+        , classType      >>= return . JavaClassField.ClassFieldType
+        , typeIdentifier >>= return . JavaClassField.VariableFieldType
+        ]
+
+classFieldModifier = choice [
+          m_reserved "final"     *> return JavaClassField.Final
+        , m_reserved "static"    *> return JavaClassField.Static
+        , m_reserved "volatile"  *> return JavaClassField.Volatile
+        , m_reserved "transient" *> return JavaClassField.Transient
+        ]
+
+classFieldVisibility = choice [
+          m_reserved "public"    *> return JavaClassFieldVisibility.Public
+        , m_reserved "private"   *> return JavaClassFieldVisibility.Private
+        , m_reserved "protected" *> return JavaClassFieldVisibility.Protected
+        ]
 
 fileLevelClass = do
         accessModifier      <- fileLevelClassAccess
         _                   <- m_reserved' "class"
         className           <- m_identifier <?> "class name"
-        let isStatic = False
         maybeModifier       <- fileLevelClassModifier
         maybeTypeParameters <- classTypeParameters
+        maybeExtends        <- optionMaybe (m_reserved "extends" *> classType)
+        maybeImplements     <- optionMaybe (m_reserved "implements" *> m_commaSep interfaceType)
+        permits             <- optionMaybe classPermits >>= return . Maybe.fromMaybe []
+        --body                <- m_braces classBody
+        let isStatic       = False
         let typeParameters = Maybe.fromMaybe [] maybeTypeParameters
-        return (JavaClass.JavaClass className accessModifier maybeModifier isStatic typeParameters)
+        let implements     = Maybe.fromMaybe [] maybeImplements
+        return (JavaClass.JavaClass className accessModifier maybeModifier isStatic typeParameters maybeExtends implements permits)
 
 fileLevelParser = do
         package <- packageParser