Fix static field accessors, support annotations in generated construc…

…tors

src/Compiler/Jvm/Asm.idr

@@ -604,6 +604,20 @@ getStringAnnotationValues : AnnotationValue -> List String
 getStringAnnotationValues (AnnArray values) = mapMaybe getStringAnnotationValue values
 getStringAnnotationValues _ = []
 
+getAnnotationValue : AnnotationValue -> Maybe Annotation
+getAnnotationValue (AnnAnnotation annotation) = Just annotation
+getAnnotationValue _ = Nothing
+
+export
+getAnnotationValues : AnnotationValue -> List Annotation
+getAnnotationValues (AnnArray values) = mapMaybe getAnnotationValue values
+getAnnotationValues _ = []
+
+export
+getAnnotationProperties : Annotation -> List AnnotationProperty
+getAnnotationProperties (MkAnnotation _ props) = props
+getAnnotationProperties _ = []
+
 public export
 data Asm : Type -> Type where
     Aaload : Asm ()

src/Compiler/Jvm/Codegen.idr

@@ -2161,16 +2161,16 @@ generateSetters descriptorsByEncloser classExport =
   generateAccessors descriptorsByEncloser classExport (createSetter classExport)
 
 generateConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport ->
-                        List FieldExport -> Asm ()
-generateConstructor descriptorsByEncloser classExport fields = do
+                        List FieldExport -> List Annotation -> Asm ()
+generateConstructor descriptorsByEncloser classExport fields annotations = do
   let fieldTypes = FieldExport.type <$> fields
   let descriptor = getMethodDescriptor $ MkInferredFunctionType IVoid fieldTypes
   let signature = Just $ getMethodSignature $ MkInferredFunctionType IVoid fieldTypes
   let classType = iref classExport.name []
   extendsTypeName <- getJvmReferenceTypeName classExport.extends
   let arity = the Int $ cast $ length fields
   jvmArgumentTypesByIndex <- LiftIo $ Map.fromList $ zip [0 .. arity] (classType :: fieldTypes)
-  CreateMethod [Public] "generated.idr" classExport.name "<init>" descriptor signature Nothing [] []
+  CreateMethod [Public] "generated.idr" classExport.name "<init>" descriptor signature Nothing annotations []
   MethodCodeStart
   CreateLabel methodStartLabel
   CreateLabel methodEndLabel
@@ -2203,11 +2203,15 @@ generateConstructor descriptorsByEncloser classExport fields = do
     let fieldType = field.type
     LocalVariable field.name (getJvmTypeDescriptor fieldType) Nothing methodStartLabel methodEndLabel index
 
-generateRequiredArgsConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm ()
-generateRequiredArgsConstructor descriptorsByEncloser classExport = do
+generateRequiredArgsConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport ->
+                                    List AnnotationProperty -> Asm ()
+generateRequiredArgsConstructor descriptorsByEncloser classExport props = do
   let allFields = getFields $ fromMaybe [] $ SortedMap.lookup classExport descriptorsByEncloser
-  let requiredFields = filter isRequiredField allFields
-  when (not $ isNil requiredFields) $ generateConstructor descriptorsByEncloser classExport requiredFields
+  let requiredFields@(_ :: _) = filter isRequiredField allFields
+        | [] => Pure ()
+  let annotations = getAnnotationValues $ snd $ fromMaybe ("annotations", AnnArray []) $
+                        (find (\(name, value) => name == "annotations") props)
+  generateConstructor descriptorsByEncloser classExport requiredFields annotations
 
 generateAllArgsConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm ()
 generateAllArgsConstructor descriptorsByEncloser classExport = do
@@ -2217,10 +2221,16 @@ generateAllArgsConstructor descriptorsByEncloser classExport = do
   let excludedFields = getStringAnnotationValues $ snd $ fromMaybe ("exclude", AnnArray []) $
                         (find (\(name, value) => name == "exclude") props)
   let constructorFields = filter (\fieldExport => not $ elem fieldExport.name excludedFields) fields
-  generateConstructor descriptorsByEncloser classExport constructorFields
+  let annotations = getAnnotationValues $ snd $ fromMaybe ("annotations", AnnArray []) $
+                      (find (\(name, value) => name == "annotations") props)
+  generateConstructor descriptorsByEncloser classExport constructorFields annotations
 
 generateNoArgsConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm ()
 generateNoArgsConstructor descriptorsByEncloser classExport = do
+  let Just (MkAnnotation _ props) = findNoArgsConstructor classExport
+        | _ => Pure ()
+  let annotations = getAnnotationValues $ snd $ fromMaybe ("annotations", AnnArray []) $
+                        (find (\(name, value) => name == "annotations") props)
   CreateMethod [Public] "generated.idr" classExport.name "<init>" "()V" Nothing Nothing [] []
   MethodCodeStart
   Aload 0
@@ -2371,7 +2381,7 @@ generateDataClass : SortedMap ClassExport (List ExportDescriptor) -> ClassExport
 generateDataClass descriptorsByEncloser classExport = do
   generateGetters descriptorsByEncloser classExport
   generateSetters descriptorsByEncloser classExport
-  generateRequiredArgsConstructor descriptorsByEncloser classExport
+  generateRequiredArgsConstructor descriptorsByEncloser classExport []
   generateHashCode descriptorsByEncloser classExport
   generateEquals descriptorsByEncloser classExport
   generateToString descriptorsByEncloser classExport
@@ -2410,10 +2420,11 @@ exportMemberIo globalState descriptorsByEncloser (MkClassExportDescriptor classE
   ignore $ asm asmState $ exportClass classExport
   let hasDataAnnotation = isJust (findClassAnnotation "Data" classExport)
   ignore $ asm asmState $ generateAllArgsConstructor descriptorsByEncloser classExport
-  when (isJust (findNoArgsConstructor classExport)) $
-    ignore $ asm asmState $ generateNoArgsConstructor descriptorsByEncloser classExport
-  when (not hasDataAnnotation && isJust (findRequiredArgsConstructor classExport)) $
-    ignore $ asm asmState $ generateRequiredArgsConstructor descriptorsByEncloser classExport
+  ignore $ asm asmState $ generateNoArgsConstructor descriptorsByEncloser classExport
+  when (not hasDataAnnotation) $
+    ignore $ asm asmState $
+      generateRequiredArgsConstructor descriptorsByEncloser classExport
+        (maybe [] getAnnotationProperties $ findRequiredArgsConstructor classExport)
   when hasDataAnnotation $ ignore $ asm asmState $ generateDataClass descriptorsByEncloser classExport
   when (not hasDataAnnotation && isJust (findClassAnnotation "Getter" classExport)) $
     ignore $ asm asmState $ generateGetters descriptorsByEncloser classExport

src/Compiler/Jvm/Export.idr

@@ -71,7 +71,7 @@ mutual
   parseAnnotationProperty : Name -> String -> String -> JSON -> Asm AnnotationProperty
   parseAnnotationProperty functionName annotationName propertyName valueJson = do
     value <- parseAnnotationValue functionName annotationName valueJson
-    Pure $ (propertyName, value)
+    Pure (propertyName, value)
 
   parseAnnotation : Name -> JSON -> Asm Annotation
   parseAnnotation functionName (JObject [(annotationName, (JObject propertyNameAndValues))]) = do

src/Compiler/Jvm/Foreign.idr

@@ -82,6 +82,13 @@ parseForeignFunctionDescriptor fc (functionDescriptor :: descriptorParts) argume
     getInstanceMemberClass errorMessage ((IRef className _ _) :: _) = Pure className
     getInstanceMemberClass errorMessage _ = Throw fc errorMessage
 
+    getDescriptorClassName : String -> Asm String
+    getDescriptorClassName memberName =
+      case descriptorParts of
+        (className :: _) => Pure className
+        _ => Throw fc
+               ("Static member " ++ memberName ++ " must have an explicit class name in foreign descriptor")
+
     getClassName : String -> List String -> InferredType -> List InferredType -> Asm String
     getClassName memberName descriptorParts returnType argumentTypes =
       let arity = length argumentTypes
@@ -90,26 +97,25 @@ parseForeignFunctionDescriptor fc (functionDescriptor :: descriptorParts) argume
             getInstanceMemberClass
               ("Instance method " ++ memberName ++ " must have first argument to be of reference type")
               argumentTypes
-        else if startsWith memberName "#=" && arity >= 2 then
-          getInstanceMemberClass
-            ("Setter for instance field " ++ memberName ++ " must have first argument to be of reference type")
-            argumentTypes
-        else if startsWith memberName "#" && arity >= 1 then
-          getInstanceMemberClass
-            ("Getter for instance field " ++ memberName ++ " must have first argument to be of reference type")
-            argumentTypes
+        else if startsWith memberName "#=" then
+          if arity >= 2 then
+            getInstanceMemberClass
+              ("Setter for instance field " ++ memberName ++ " must have first argument to be of reference type")
+              argumentTypes
+          else getDescriptorClassName memberName
+        else if startsWith memberName "#" then
+          if arity >= 1 then
+            getInstanceMemberClass
+              ("Getter for instance field " ++ memberName ++ " must have first argument to be of reference type")
+              argumentTypes
+          else getDescriptorClassName memberName
         else
           if memberName == "<init>"
             then
               case returnType of
                 IRef className _ _ => Pure className
                 _ => Throw fc ("Constructor must return a reference type")
-            else
-              case descriptorParts of
-                (className :: _) => Pure className
-                _ => Throw fc
-                       ("Static member " ++ memberName ++ " must have an explicit class name in foreign descriptor")
-
+            else getDescriptorClassName memberName
 
     go : List InferredType -> List String -> Asm (List InferredType, InferredType)
     go acc [] = Pure (acc, IUnknown)