-- | Various fixups in the introspection data.
module Data.GI.CodeGen.Fixups
    ( dropMovedItems
    , guessPropertyNullability
    , detectGObject
    , dropDuplicatedFields
    , checkClosureDestructors
    ) where

import Data.Maybe (isNothing, isJust)
#if !MIN_VERSION_base(4,13,0)
import Data.Monoid ((<>))
#endif
import qualified Data.Set as S
import qualified Data.Text as T

import Data.GI.CodeGen.API

-- | Remove functions and methods annotated with "moved-to".
dropMovedItems :: API -> Maybe API
dropMovedItems :: API -> Maybe API
dropMovedItems (APIFunction f :: Function
f) = if Function -> Maybe Text
fnMovedTo Function
f Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing
                                 then API -> Maybe API
forall a. a -> Maybe a
Just (Function -> API
APIFunction Function
f)
                                 else Maybe API
forall a. Maybe a
Nothing
dropMovedItems (APIInterface i :: Interface
i) =
    (API -> Maybe API
forall a. a -> Maybe a
Just (API -> Maybe API) -> (Interface -> API) -> Interface -> Maybe API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> API
APIInterface) Interface
i {ifMethods :: [Method]
ifMethods = [Method] -> [Method]
filterMovedMethods (Interface -> [Method]
ifMethods Interface
i)}
dropMovedItems (APIObject o :: Object
o) =
    (API -> Maybe API
forall a. a -> Maybe a
Just (API -> Maybe API) -> (Object -> API) -> Object -> Maybe API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> API
APIObject) Object
o {objMethods :: [Method]
objMethods = [Method] -> [Method]
filterMovedMethods (Object -> [Method]
objMethods Object
o)}
dropMovedItems (APIStruct s :: Struct
s) =
    (API -> Maybe API
forall a. a -> Maybe a
Just (API -> Maybe API) -> (Struct -> API) -> Struct -> Maybe API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct -> API
APIStruct) Struct
s {structMethods :: [Method]
structMethods = [Method] -> [Method]
filterMovedMethods (Struct -> [Method]
structMethods Struct
s)}
dropMovedItems (APIUnion u :: Union
u) =
    (API -> Maybe API
forall a. a -> Maybe a
Just (API -> Maybe API) -> (Union -> API) -> Union -> Maybe API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Union -> API
APIUnion) Union
u {unionMethods :: [Method]
unionMethods = [Method] -> [Method]
filterMovedMethods (Union -> [Method]
unionMethods Union
u)}
dropMovedItems a :: API
a = API -> Maybe API
forall a. a -> Maybe a
Just API
a

-- | Drop the moved methods.
filterMovedMethods :: [Method] -> [Method]
filterMovedMethods :: [Method] -> [Method]
filterMovedMethods = (Method -> Bool) -> [Method] -> [Method]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Text -> Bool) -> (Method -> Maybe Text) -> Method -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Maybe Text
methodMovedTo)

-- | GObject-introspection does not currently support nullability
-- annotations, so we try to guess the nullability from the
-- nullability annotations of the curresponding get/set methods, which
-- in principle should be reliable.
guessPropertyNullability :: (Name, API) -> (Name, API)
guessPropertyNullability :: (Name, API) -> (Name, API)
guessPropertyNullability (n :: Name
n, APIObject obj :: Object
obj) =
    (Name
n, Object -> API
APIObject (Object -> Object
guessObjectPropertyNullability Object
obj))
guessPropertyNullability (n :: Name
n, APIInterface iface :: Interface
iface) =
    (Name
n, Interface -> API
APIInterface (Interface -> Interface
guessInterfacePropertyNullability Interface
iface))
guessPropertyNullability other :: (Name, API)
other = (Name, API)
other

-- | Guess nullability for the properties of an object.
guessObjectPropertyNullability :: Object -> Object
guessObjectPropertyNullability :: Object -> Object
guessObjectPropertyNullability obj :: Object
obj =
    Object
obj {objProperties :: [Property]
objProperties = (Property -> Property) -> [Property] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map ([Method] -> Property -> Property
guessNullability (Object -> [Method]
objMethods Object
obj))
                         (Object -> [Property]
objProperties Object
obj)}

-- | Guess nullability for the properties of an interface.
guessInterfacePropertyNullability :: Interface -> Interface
guessInterfacePropertyNullability :: Interface -> Interface
guessInterfacePropertyNullability iface :: Interface
iface =
    Interface
iface {ifProperties :: [Property]
ifProperties = (Property -> Property) -> [Property] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map ([Method] -> Property -> Property
guessNullability (Interface -> [Method]
ifMethods Interface
iface))
                              (Interface -> [Property]
ifProperties Interface
iface)}

-- | Guess the nullability for a property, given the list of methods
-- for the object/interface.
guessNullability :: [Method] -> Property -> Property
guessNullability :: [Method] -> Property -> Property
guessNullability methods :: [Method]
methods = [Method] -> Property -> Property
guessReadNullability [Method]
methods
                         (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Method] -> Property -> Property
guessWriteNullability [Method]
methods

-- | Guess whether "get" on the given property may return NULL, based
-- on the corresponding "get_prop_name" method, if it exists.
guessReadNullability :: [Method] -> Property -> Property
guessReadNullability :: [Method] -> Property -> Property
guessReadNullability methods :: [Method]
methods p :: Property
p
    | Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust (Property -> Maybe Bool
propReadNullable Property
p) = Property
p
    | Bool
otherwise = Property
p {propReadNullable :: Maybe Bool
propReadNullable = Maybe Bool
nullableGetter}
    where
      nullableGetter :: Maybe Bool
      nullableGetter :: Maybe Bool
nullableGetter =
          let prop_name :: Text
prop_name = Text -> Text -> Text -> Text
T.replace "-" "_" (Property -> Text
propName Property
p)
          in case [Method] -> Text -> Maybe Method
findMethod [Method]
methods ("get_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prop_name) of
               Nothing -> Maybe Bool
forall a. Maybe a
Nothing
               -- Check that it looks like a sensible getter
               -- for the property.
               Just m :: Method
m ->
                   let c :: Callable
c = Method -> Callable
methodCallable Method
m
                   in if [Arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Callable -> [Arg]
args Callable
c) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
&&
                      Callable -> Maybe Type
returnType Callable
c Maybe Type -> Maybe Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Maybe Type
forall a. a -> Maybe a
Just (Property -> Type
propType Property
p) Bool -> Bool -> Bool
&&
                      Callable -> Transfer
returnTransfer Callable
c Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferNothing Bool -> Bool -> Bool
&&
                      Callable -> Bool
skipReturn Callable
c Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False Bool -> Bool -> Bool
&&
                      Callable -> Bool
callableThrows Callable
c Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False Bool -> Bool -> Bool
&&
                      Method -> MethodType
methodType Method
m MethodType -> MethodType -> Bool
forall a. Eq a => a -> a -> Bool
== MethodType
OrdinaryMethod Bool -> Bool -> Bool
&&
                      Method -> Maybe Text
methodMovedTo Method
m Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing
                      then Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Callable -> Bool
returnMayBeNull Callable
c)
                      else Maybe Bool
forall a. Maybe a
Nothing

-- | Guess whether "set" on the given property may return NULL, based
-- on the corresponding "set_prop_name" method, if it exists.
guessWriteNullability :: [Method] -> Property -> Property
guessWriteNullability :: [Method] -> Property -> Property
guessWriteNullability methods :: [Method]
methods p :: Property
p
    | Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust (Property -> Maybe Bool
propWriteNullable Property
p) = Property
p
    | Bool
otherwise = Property
p {propWriteNullable :: Maybe Bool
propWriteNullable = Maybe Bool
nullableSetter}
    where
      nullableSetter :: Maybe Bool
      nullableSetter :: Maybe Bool
nullableSetter =
          let prop_name :: Text
prop_name = Text -> Text -> Text -> Text
T.replace "-" "_" (Property -> Text
propName Property
p)
          in case [Method] -> Text -> Maybe Method
findMethod [Method]
methods ("set_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prop_name) of
               Nothing -> Maybe Bool
forall a. Maybe a
Nothing
               -- Check that it looks like a sensible setter.
               Just m :: Method
m ->
                   let c :: Callable
c = Method -> Callable
methodCallable Method
m
                   in if [Arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Callable -> [Arg]
args Callable
c) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 Bool -> Bool -> Bool
&&
                          (Arg -> Type
argType (Arg -> Type) -> (Callable -> Arg) -> Callable -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Arg] -> Arg
forall a. [a] -> a
last ([Arg] -> Arg) -> (Callable -> [Arg]) -> Callable -> Arg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Callable -> [Arg]
args) Callable
c Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Property -> Type
propType Property
p Bool -> Bool -> Bool
&&
                          Callable -> Maybe Type
returnType Callable
c Maybe Type -> Maybe Type -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Type
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&&
                          (Arg -> Transfer
transfer (Arg -> Transfer) -> (Callable -> Arg) -> Callable -> Transfer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Arg] -> Arg
forall a. [a] -> a
last ([Arg] -> Arg) -> (Callable -> [Arg]) -> Callable -> Arg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Callable -> [Arg]
args) Callable
c Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferNothing Bool -> Bool -> Bool
&&
                          (Arg -> Direction
direction (Arg -> Direction) -> (Callable -> Arg) -> Callable -> Direction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Arg] -> Arg
forall a. [a] -> a
last ([Arg] -> Arg) -> (Callable -> [Arg]) -> Callable -> Arg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Callable -> [Arg]
args) Callable
c Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
== Direction
DirectionIn Bool -> Bool -> Bool
&&
                          Method -> Maybe Text
methodMovedTo Method
m Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&&
                          Method -> MethodType
methodType Method
m MethodType -> MethodType -> Bool
forall a. Eq a => a -> a -> Bool
== MethodType
OrdinaryMethod Bool -> Bool -> Bool
&&
                          Callable -> Bool
callableThrows Callable
c Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False
                      then Bool -> Maybe Bool
forall a. a -> Maybe a
Just ((Arg -> Bool
mayBeNull (Arg -> Bool) -> (Callable -> Arg) -> Callable -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Arg] -> Arg
forall a. [a] -> a
last ([Arg] -> Arg) -> (Callable -> [Arg]) -> Callable -> Arg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Callable -> [Arg]
args) Callable
c)
                      else Maybe Bool
forall a. Maybe a
Nothing

-- | Find the first method with the given name, if any.
findMethod :: [Method] -> T.Text -> Maybe Method
findMethod :: [Method] -> Text -> Maybe Method
findMethod methods :: [Method]
methods n :: Text
n = case (Method -> Bool) -> [Method] -> [Method]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
n) (Text -> Bool) -> (Method -> Text) -> Method -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
name (Name -> Text) -> (Method -> Name) -> Method -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName) [Method]
methods of
                         [m :: Method
m] -> Method -> Maybe Method
forall a. a -> Maybe a
Just Method
m
                         _ -> Maybe Method
forall a. Maybe a
Nothing

-- | Not every interface that provides signals/properties is marked as
-- requiring GObject, but this is necessarily the case, so fix the
-- introspection data accordingly.
detectGObject :: (Name, API) -> (Name, API)
detectGObject :: (Name, API) -> (Name, API)
detectGObject (n :: Name
n, APIInterface iface :: Interface
iface) =
  if Bool -> Bool
not ([Property] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Interface -> [Property]
ifProperties Interface
iface) Bool -> Bool -> Bool
&& [Signal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Interface -> [Signal]
ifSignals Interface
iface))
  then let gobject :: Name
gobject = Text -> Text -> Name
Name "GObject" "Object"
       in if Name
gobject Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Interface -> [Name]
ifPrerequisites Interface
iface)
          then (Name
n, Interface -> API
APIInterface Interface
iface)
          else (Name
n, Interface -> API
APIInterface (Interface
iface {ifPrerequisites :: [Name]
ifPrerequisites =
                                        Name
gobject Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Interface -> [Name]
ifPrerequisites Interface
iface}))
  else (Name
n, Interface -> API
APIInterface Interface
iface)
detectGObject api :: (Name, API)
api = (Name, API)
api

-- | Drop any fields whose name coincides with that of a previous
-- element. Note that this function keeps ordering.
dropDuplicatedEnumFields :: Enumeration -> Enumeration
dropDuplicatedEnumFields :: Enumeration -> Enumeration
dropDuplicatedEnumFields enum :: Enumeration
enum =
  Enumeration
enum{enumMembers :: [EnumerationMember]
enumMembers = Set Text -> [EnumerationMember] -> [EnumerationMember]
dropDuplicates Set Text
forall a. Set a
S.empty (Enumeration -> [EnumerationMember]
enumMembers Enumeration
enum)}
  where dropDuplicates :: S.Set T.Text -> [EnumerationMember] -> [EnumerationMember]
        dropDuplicates :: Set Text -> [EnumerationMember] -> [EnumerationMember]
dropDuplicates _        []     = []
        dropDuplicates previous :: Set Text
previous (m :: EnumerationMember
m:ms :: [EnumerationMember]
ms) =
          if EnumerationMember -> Text
enumMemberName EnumerationMember
m Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
previous
          then Set Text -> [EnumerationMember] -> [EnumerationMember]
dropDuplicates Set Text
previous [EnumerationMember]
ms
          else EnumerationMember
m EnumerationMember -> [EnumerationMember] -> [EnumerationMember]
forall a. a -> [a] -> [a]
: Set Text -> [EnumerationMember] -> [EnumerationMember]
dropDuplicates (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert (EnumerationMember -> Text
enumMemberName EnumerationMember
m) Set Text
previous) [EnumerationMember]
ms

-- | Some libraries include duplicated flags by mistake, drop those.
dropDuplicatedFields :: (Name, API) -> (Name, API)
dropDuplicatedFields :: (Name, API) -> (Name, API)
dropDuplicatedFields (n :: Name
n, APIFlags (Flags enum :: Enumeration
enum)) =
  (Name
n, Flags -> API
APIFlags (Enumeration -> Flags
Flags (Enumeration -> Flags) -> Enumeration -> Flags
forall a b. (a -> b) -> a -> b
$ Enumeration -> Enumeration
dropDuplicatedEnumFields Enumeration
enum))
dropDuplicatedFields (n :: Name
n, api :: API
api) = (Name
n, API
api)

-- | Sometimes arguments are marked as being a user_data destructor,
-- but there is no associated user_data argument. In this case we drop
-- the annotation.
checkClosureDestructors :: (Name, API) -> (Name, API)
checkClosureDestructors :: (Name, API) -> (Name, API)
checkClosureDestructors (n :: Name
n, APIObject o :: Object
o) =
  (Name
n, Object -> API
APIObject (Object
o {objMethods :: [Method]
objMethods = [Method] -> [Method]
checkMethodDestructors (Object -> [Method]
objMethods Object
o)}))
checkClosureDestructors (n :: Name
n, APIInterface i :: Interface
i) =
  (Name
n, Interface -> API
APIInterface (Interface
i {ifMethods :: [Method]
ifMethods = [Method] -> [Method]
checkMethodDestructors (Interface -> [Method]
ifMethods Interface
i)}))
checkClosureDestructors (n :: Name
n, APIStruct s :: Struct
s) =
  (Name
n, Struct -> API
APIStruct (Struct
s {structMethods :: [Method]
structMethods = [Method] -> [Method]
checkMethodDestructors (Struct -> [Method]
structMethods Struct
s)}))
checkClosureDestructors (n :: Name
n, APIUnion u :: Union
u) =
  (Name
n, Union -> API
APIUnion (Union
u {unionMethods :: [Method]
unionMethods = [Method] -> [Method]
checkMethodDestructors (Union -> [Method]
unionMethods Union
u)}))
checkClosureDestructors (n :: Name
n, APIFunction f :: Function
f) =
  (Name
n, Function -> API
APIFunction (Function
f {fnCallable :: Callable
fnCallable = Callable -> Callable
checkCallableDestructors (Function -> Callable
fnCallable Function
f)}))
checkClosureDestructors (n :: Name
n, api :: API
api) = (Name
n, API
api)

checkMethodDestructors :: [Method] -> [Method]
checkMethodDestructors :: [Method] -> [Method]
checkMethodDestructors = (Method -> Method) -> [Method] -> [Method]
forall a b. (a -> b) -> [a] -> [b]
map Method -> Method
checkMethod
  where checkMethod :: Method -> Method
        checkMethod :: Method -> Method
checkMethod m :: Method
m = Method
m {methodCallable :: Callable
methodCallable =
                             Callable -> Callable
checkCallableDestructors (Method -> Callable
methodCallable Method
m)}

-- | If any argument for the callable has a associated destroyer for
-- the user_data, but no associated user_data, drop the destroyer
-- annotation.
checkCallableDestructors :: Callable -> Callable
checkCallableDestructors :: Callable -> Callable
checkCallableDestructors c :: Callable
c = Callable
c {args :: [Arg]
args = (Arg -> Arg) -> [Arg] -> [Arg]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> Arg
checkArg (Callable -> [Arg]
args Callable
c)}
  where checkArg :: Arg -> Arg
        checkArg :: Arg -> Arg
checkArg arg :: Arg
arg = if Arg -> Int
argDestroy Arg
arg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Arg -> Int
argClosure Arg
arg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -1
                       then Arg
arg {argDestroy :: Int
argDestroy = -1}
                       else Arg
arg