Class Type Parameter Parsing, wtf

src/Syntax.hs

@@ -0,0 +1,205 @@
+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 PrimitiveTypes
+
+import Data.Functor.Identity
+import qualified Data.List as List
+import qualified Data.Maybe as Maybe
+
+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"
+
+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 <- (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)
+
+recursiveClassType = do
+        classType_ <- classType
+        _ <- char '.'
+        unqualifiedType <- typeIdentifier
+        maybeTypeArguments <- optionMaybe $ m_angles (m_commaSep1 typeArgument)
+        let typeArguments = Maybe.fromMaybe [] maybeTypeArguments
+        return (ClassTypeParameter.RecursiveTypeBound classType_ unqualifiedType typeArguments)
+
+classType = choice [ qualifiedClassType
+        , unqualifiedClassType
+        , recursiveClassType
+        ]
+
+classTypeParameterClassOrInterfaceBound = do
+        classType_ <- classType
+        interfaces <- m_commaSep1 interfaceType
+        return (ClassTypeParameter.ClassTypeBound classType_ interfaces)
+
+classTypeParameterBound = do
+        _ <- m_reserved' "extends"
+        bound <- choice [ typeIdentifier >>= return . ClassTypeParameter.SimpleTypeBound
+                , classTypeParameterClassOrInterfaceBound
+                ]
+        return bound
+
+classTypeParameter = do
+        name <- typeIdentifier
+        typeBound <- optionMaybe classTypeParameterBound
+        -- TODO: Interfaces
+        return (ClassTypeParameter.ClassTypeParameter name typeBound [])
+
+classTypeParameters = optionMaybe $ m_angles $ (classTypeParameter `sepBy1` (m_symbol ","))
+
+fileLevelClass= do
+        accessModifier <- fileLevelClassAccess
+        _ <- m_reserved' "class"
+        className <- m_identifier <?> "class name"
+        let isStatic = False
+        maybeModifier <- fileLevelClassModifier
+        maybeTypeParameters <- classTypeParameters
+        let typeParameters = Maybe.fromMaybe [] maybeTypeParameters
+        return (JavaClass.JavaClass className accessModifier maybeModifier isStatic typeParameters)
+
+fileLevelParser = do
+        package <- packageParser
+        imports <- many importParser
+        classes <- many (choice [fileLevelClass])
+        return (JavaFile.JavaFile package imports classes)
+