281 lines
10 KiB
Haskell
281 lines
10 KiB
Haskell
module Syntax
|
|
( module Syntax
|
|
)
|
|
where
|
|
|
|
import Text.Parsec.Language
|
|
import Text.Parsec.Token
|
|
import Text.Parsec.Combinator
|
|
import Text.Parsec
|
|
|
|
import qualified JavaClass as JavaClass
|
|
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 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
|
|
, commaSep = m_commaSep
|
|
, angles = m_angles
|
|
, braces = m_braces
|
|
, reservedOp = m_reservedOp } = makeTokenParser javaLanguageDef
|
|
|
|
javaPathParser = m_identifier `sepBy1` (string ".")
|
|
|
|
semicolon = (m_lexeme . char $ ';') <?> "semicolon"
|
|
|
|
m_reserved' s = m_reserved s <?> s
|
|
|
|
typeIdentifier = m_identifier
|
|
|
|
packageParser = do
|
|
_ <- m_reserved' "package"
|
|
name <- m_lexeme javaPathParser <?> "package path"
|
|
_ <- semicolon
|
|
return (List.intercalate "." name)
|
|
|
|
importParser = do
|
|
_ <- m_reserved' "import"
|
|
name <- m_lexeme javaPathParser <?> "import class path"
|
|
_ <- semicolon
|
|
return (List.intercalate "." name)
|
|
|
|
fileLevelClassAccess = do
|
|
maybeAccess <- optionMaybe $ m_reserved' "public" *> return JavaClassAccess.Public
|
|
return (Maybe.fromMaybe JavaClassAccess.PackagePrivate maybeAccess)
|
|
|
|
fileLevelClassModifier = optionMaybe $ choice [ m_reserved' "final" *> return JavaClassModifier.Final
|
|
, m_reserved' "sealed" *> return JavaClassModifier.Sealed
|
|
, m_reserved' "non-sealed" *> return JavaClassModifier.NonSealed
|
|
]
|
|
|
|
interfaceType = classType
|
|
|
|
typeArgument = choice [
|
|
wildCardType >>= return . ClassTypeParameter.WildCardTypeArgument
|
|
, referenceType >>= return . ClassTypeParameter.ReferenceTypeArgument
|
|
]
|
|
|
|
wildCardType = do
|
|
_ <- m_symbol "?"
|
|
bound <- optionMaybe wildCardBound
|
|
return (ClassTypeParameter.WildCard bound)
|
|
|
|
wildCardBound = choice [ wildCardSuperBound , wildCardExtendsBound ]
|
|
|
|
wildCardSuperBound = do
|
|
_ <- m_reserved "super"
|
|
referenceType >>= return . ClassTypeParameter.SuperWildCardBound
|
|
|
|
wildCardExtendsBound = do
|
|
_ <- m_reserved "extends"
|
|
referenceType >>= return . ClassTypeParameter.ExtendsWildCardBound
|
|
|
|
-- TODO: Fix infinite recursion with typeArgument
|
|
referenceType = choice [
|
|
typeIdentifier >>= return . ClassTypeParameter.VariableReferenceType
|
|
, classType >>= return . ClassTypeParameter.ClassReferenceType
|
|
, arrayType >>= return . ClassTypeParameter.ArrayReferenceType
|
|
]
|
|
|
|
arrayType = do
|
|
partialConstructor <- choice [ primitiveType >>= return . ClassTypeParameter.PrimitiveArrayType
|
|
, classType >>= return . ClassTypeParameter.ClassArrayType
|
|
, typeIdentifier >>= return . ClassTypeParameter.VariableArrayType
|
|
]
|
|
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)
|
|
let typeArguments = Maybe.fromMaybe [] maybeTypeArguments
|
|
return (ClassTypeParameter.NonRecursiveTypeBound qualifiedType typeArguments)
|
|
|
|
unqualifiedClassType = do
|
|
unqualifiedType <- typeIdentifier
|
|
maybeTypeArguments <- optionMaybe $ m_angles (m_commaSep1 typeArgument)
|
|
let typeArguments = Maybe.fromMaybe [] maybeTypeArguments
|
|
return (ClassTypeParameter.NonRecursiveTypeBound unqualifiedType typeArguments)
|
|
|
|
-- TODO: Review this, i cancelled the left-recursive rule
|
|
recursiveClassType = do
|
|
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
|
|
, unqualifiedClassType
|
|
, recursiveClassType
|
|
]
|
|
|
|
classTypeParameterClassOrInterfaceBound = do
|
|
classType_ <- classType
|
|
interfaces <- m_commaSep interfaceType
|
|
return (ClassTypeParameter.ClassTypeBound classType_ interfaces)
|
|
|
|
classTypeParameterBound = do
|
|
_ <- m_reserved' "extends"
|
|
bound <- choice [
|
|
try classTypeParameterClassOrInterfaceBound
|
|
, typeIdentifier >>= return . ClassTypeParameter.SimpleTypeBound
|
|
]
|
|
return bound
|
|
|
|
classTypeParameter = do
|
|
name <- typeIdentifier
|
|
typeBound <- optionMaybe classTypeParameterBound
|
|
-- TODO: Interfaces
|
|
return (ClassTypeParameter.ClassTypeParameter name typeBound [])
|
|
|
|
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"
|
|
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
|
|
let implements = Maybe.fromMaybe [] maybeImplements
|
|
return (JavaClass.JavaClass className accessModifier maybeModifier isStatic typeParameters maybeExtends implements permits)
|
|
|
|
fileLevelParser = do
|
|
package <- packageParser
|
|
imports <- many importParser
|
|
classes <- many (choice [fileLevelClass])
|
|
return (JavaFile.JavaFile package imports classes)
|
|
|