diff --git a/src/Compiler/Jvm/Asm.idr b/src/Compiler/Jvm/Asm.idr index bf71b309c..b8a2f052b 100644 --- a/src/Compiler/Jvm/Asm.idr +++ b/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 () diff --git a/src/Compiler/Jvm/Codegen.idr b/src/Compiler/Jvm/Codegen.idr index 8612c8713..5d4ea882f 100644 --- a/src/Compiler/Jvm/Codegen.idr +++ b/src/Compiler/Jvm/Codegen.idr @@ -2161,8 +2161,8 @@ 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 @@ -2170,7 +2170,7 @@ generateConstructor descriptorsByEncloser classExport fields = do 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 "" descriptor signature Nothing [] [] + CreateMethod [Public] "generated.idr" classExport.name "" 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 "" "()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 diff --git a/src/Compiler/Jvm/Export.idr b/src/Compiler/Jvm/Export.idr index cfdb1dba7..83c08138a 100644 --- a/src/Compiler/Jvm/Export.idr +++ b/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 diff --git a/src/Compiler/Jvm/Foreign.idr b/src/Compiler/Jvm/Foreign.idr index d1fb950bc..0a71e2947 100644 --- a/src/Compiler/Jvm/Foreign.idr +++ b/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 == "" 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)