module Data.GI.CodeGen.OverloadedLabels
    ( genOverloadedLabels
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Data.Maybe (isNothing)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Control.Monad (forM_)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.SymbolNaming
import Data.GI.CodeGen.Util (lcFirst)

-- | A list of all overloadable identifiers in the set of APIs (current
-- properties and methods).
findOverloaded :: [(Name, API)] -> CodeGen [Text]
findOverloaded :: [(Name, API)] -> CodeGen [Text]
findOverloaded [(Name, API)]
apis = Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Set Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis Set Text
forall a. Set a
S.empty
    where
      go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)
      go :: [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [] Set Text
set = Set Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Set Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Text
set
      go ((Name
_, API
api):[(Name, API)]
apis) Set Text
set =
        case API
api of
          APIInterface Interface
iface -> [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis (Interface -> Set Text -> Set Text
scanInterface Interface
iface Set Text
set)
          APIObject Object
object -> [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis (Object -> Set Text -> Set Text
scanObject Object
object Set Text
set)
          APIStruct Struct
s -> [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis (Struct -> Set Text -> Set Text
scanStruct Struct
s Set Text
set)
          APIUnion Union
u -> [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis (Union -> Set Text -> Set Text
scanUnion Union
u Set Text
set)
          API
_ -> [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis Set Text
set

      scanObject :: Object -> S.Set Text -> S.Set Text
      scanObject :: Object -> Set Text -> Set Text
scanObject Object
o Set Text
set =
          let props :: [Text]
props = ((Property -> Text) -> [Property] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Text
propToLabel ([Property] -> [Text])
-> (Object -> [Property]) -> Object -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Property]
objProperties) Object
o
              methods :: [Text]
methods = ((Method -> Text) -> [Method] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Method -> Text
methodToLabel ([Method] -> [Text]) -> (Object -> [Method]) -> Object -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Method] -> [Method]
filterMethods ([Method] -> [Method])
-> (Object -> [Method]) -> Object -> [Method]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Method]
objMethods) Object
o
          in [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Text
set, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
props, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
methods]

      scanInterface :: Interface -> S.Set Text -> S.Set Text
      scanInterface :: Interface -> Set Text -> Set Text
scanInterface Interface
i Set Text
set =
          let props :: [Text]
props = ((Property -> Text) -> [Property] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Text
propToLabel ([Property] -> [Text])
-> (Interface -> [Property]) -> Interface -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> [Property]
ifProperties) Interface
i
              methods :: [Text]
methods = ((Method -> Text) -> [Method] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Method -> Text
methodToLabel ([Method] -> [Text])
-> (Interface -> [Method]) -> Interface -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Method] -> [Method]
filterMethods ([Method] -> [Method])
-> (Interface -> [Method]) -> Interface -> [Method]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> [Method]
ifMethods) Interface
i
          in [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Text
set, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
props, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
methods]

      scanStruct :: Struct -> S.Set Text -> S.Set Text
      scanStruct :: Struct -> Set Text -> Set Text
scanStruct Struct
s Set Text
set =
          let attrs :: [Text]
attrs = ((Field -> Text) -> [Field] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Text
fieldToLabel ([Field] -> [Text]) -> (Struct -> [Field]) -> Struct -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Field] -> [Field]
filterFields ([Field] -> [Field]) -> (Struct -> [Field]) -> Struct -> [Field]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct -> [Field]
structFields) Struct
s
              methods :: [Text]
methods = ((Method -> Text) -> [Method] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Method -> Text
methodToLabel ([Method] -> [Text]) -> (Struct -> [Method]) -> Struct -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Method] -> [Method]
filterMethods ([Method] -> [Method])
-> (Struct -> [Method]) -> Struct -> [Method]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Struct -> [Method]
structMethods) Struct
s
          in [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Text
set, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
attrs, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
methods]

      scanUnion :: Union -> S.Set Text -> S.Set Text
      scanUnion :: Union -> Set Text -> Set Text
scanUnion Union
u Set Text
set =
          let attrs :: [Text]
attrs = ((Field -> Text) -> [Field] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Text
fieldToLabel ([Field] -> [Text]) -> (Union -> [Field]) -> Union -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Field] -> [Field]
filterFields ([Field] -> [Field]) -> (Union -> [Field]) -> Union -> [Field]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Union -> [Field]
unionFields) Union
u
              methods :: [Text]
methods = ((Method -> Text) -> [Method] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Method -> Text
methodToLabel ([Method] -> [Text]) -> (Union -> [Method]) -> Union -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Method] -> [Method]
filterMethods ([Method] -> [Method]) -> (Union -> [Method]) -> Union -> [Method]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Union -> [Method]
unionMethods) Union
u
          in [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Text
set, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
attrs, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
methods]

      propToLabel :: Property -> Text
      propToLabel :: Property -> Text
propToLabel = Text -> Text
lcFirst (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphensToCamelCase (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
propName

      methodToLabel :: Method -> Text
      methodToLabel :: Method -> Text
methodToLabel = Name -> Text
lowerName (Name -> Text) -> (Method -> Name) -> Method -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName

      fieldToLabel :: Field -> Text
      fieldToLabel :: Field -> Text
fieldToLabel = Text -> Text
lcFirst (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
underscoresToCamelCase (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName

      filterMethods :: [Method] -> [Method]
      filterMethods :: [Method] -> [Method]
filterMethods = (Method -> Bool) -> [Method] -> [Method]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Method
m -> (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) Method
m Bool -> Bool -> Bool
&&
                                    Method -> MethodType
methodType Method
m MethodType -> MethodType -> Bool
forall a. Eq a => a -> a -> Bool
== MethodType
OrdinaryMethod)

      filterFields :: [Field] -> [Field]
      filterFields :: [Field] -> [Field]
filterFields = (Field -> Bool) -> [Field] -> [Field]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Field
f -> Field -> Bool
fieldVisible Field
f Bool -> Bool -> Bool
&&
                            (Bool -> Bool
not (Bool -> Bool) -> (Field -> Bool) -> Field -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (Field -> Text) -> Field -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
f)

genOverloadedLabel :: Text -> CodeGen ()
genOverloadedLabel :: Text -> CodeGen ()
genOverloadedLabel Text
l = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: IsLabelProxy \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" a => a"
  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = fromLabelProxy (Proxy :: Proxy \""
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\")"
  HaddockSection -> Text -> CodeGen ()
export HaddockSection
ToplevelSection (Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l)

genOverloadedLabels :: [(Name, API)] -> CodeGen ()
genOverloadedLabels :: [(Name, API)] -> CodeGen ()
genOverloadedLabels [(Name, API)]
allAPIs = do
  [Text] -> CodeGen ()
setLanguagePragmas [Text
"DataKinds", Text
"FlexibleContexts", Text
"CPP"]
  [ModuleFlag] -> CodeGen ()
setModuleFlags [ModuleFlag
ImplicitPrelude]

  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"import Data.Proxy (Proxy(..))"
  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"import Data.GI.Base.Overloading (IsLabelProxy(..))"
  BaseCodeGen e ()
CodeGen ()
blank

  [Text]
labels <- [(Name, API)] -> CodeGen [Text]
findOverloaded [(Name, API)]
allAPIs
  [Text] -> (Text -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
labels ((Text -> BaseCodeGen e ()) -> BaseCodeGen e ())
-> (Text -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ \Text
l -> do
      Text -> CodeGen ()
genOverloadedLabel Text
l
      BaseCodeGen e ()
CodeGen ()
blank