module Data.GI.CodeGen.OverloadedSignals
    ( genObjectSignals
    , genInterfaceSignals
    , genOverloadedSignalConnectors
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, when)

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

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Inheritance (fullObjectSignalList, fullInterfaceSignalList)
import Data.GI.CodeGen.GObject (apiIsGObject)
import Data.GI.CodeGen.SymbolNaming (upperName, hyphensToCamelCase,
                                     signalInfoName)
import Data.GI.CodeGen.Util (lcFirst)

-- A list of distinct signal names for all GObjects appearing in the
-- given list of APIs.
findSignalNames :: [(Name, API)] -> CodeGen [Text]
findSignalNames :: [(Name, API)] -> CodeGen [Text]
findSignalNames apis :: [(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 :: 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 ((_, api :: API
api):apis :: [(Name, API)]
apis) set :: Set Text
set =
          case API
api of
            APIInterface iface :: Interface
iface ->
                [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis (Set Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Set Text))
-> Set Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Set Text)
forall a b. (a -> b) -> a -> b
$ [Signal] -> Set Text -> Set Text
insertSignals (Interface -> [Signal]
ifSignals Interface
iface) Set Text
set
            APIObject object :: Object
object ->
                [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis (Set Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Set Text))
-> Set Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Set Text)
forall a b. (a -> b) -> a -> b
$ [Signal] -> Set Text -> Set Text
insertSignals (Object -> [Signal]
objSignals Object
object) Set Text
set
            _ -> [(Name, API)] -> Set Text -> CodeGen (Set Text)
go [(Name, API)]
apis Set Text
set

      insertSignals :: [Signal] -> S.Set Text -> S.Set Text
      insertSignals :: [Signal] -> Set Text -> Set Text
insertSignals props :: [Signal]
props set :: Set Text
set = (Signal -> Set Text -> Set Text)
-> Set Text -> [Signal] -> Set Text
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert (Text -> Set Text -> Set Text)
-> (Signal -> Text) -> Signal -> Set Text -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName) Set Text
set [Signal]
props

-- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ...
genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen ()
genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen ()
genOverloadedSignalConnectors allAPIs :: [(Name, API)]
allAPIs = do
  [Text] -> CodeGen ()
setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP",
                      -- For ghc 7.8 support
                      "RankNTypes", "ScopedTypeVariables", "TypeFamilies"]
  [ModuleFlag] -> CodeGen ()
setModuleFlags [ModuleFlag
ImplicitPrelude]

  Text -> CodeGen ()
line "import Data.GI.Base.Signals (SignalProxy(..))"
  Text -> CodeGen ()
line "import Data.GI.Base.Overloading (ResolveSignal)"
  BaseCodeGen e ()
CodeGen ()
blank
  [Text]
signalNames <- [(Name, API)] -> CodeGen [Text]
findSignalNames [(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]
signalNames ((Text -> BaseCodeGen e ()) -> BaseCodeGen e ())
-> (Text -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ \sn :: Text
sn -> 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
    let camelName :: Text
camelName = Text -> Text
hyphensToCamelCase Text
sn
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "pattern " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
camelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             " :: SignalProxy object (ResolveSignal \""
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst Text
camelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" object)"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "pattern " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
camelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = SignalProxy"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
exportDecl (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "pattern " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
camelName

-- | Signal instances for (GObject-derived) objects.
genObjectSignals :: Name -> Object -> CodeGen ()
genObjectSignals :: Name -> Object -> CodeGen ()
genObjectSignals n :: Name
n o :: Object
o = do
  let name :: Text
name = Name -> Text
upperName Name
n
  Bool
isGO <- Name -> API -> CodeGen Bool
apiIsGObject Name
n (Object -> API
APIObject Object
o)
  Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isGO (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ do
       [Text]
infos <- Name -> Object -> CodeGen [(Name, Signal)]
fullObjectSignalList Name
n Object
o BaseCodeGen e [(Name, Signal)]
-> ([(Name, Signal)]
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                ((Name, Signal)
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [(Name, Signal)]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(owner :: Name
owner, signal :: Signal
signal) -> do
                      Text
si <- Name -> Signal -> CodeGen Text
signalInfoName Name
owner Signal
signal
                      Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "'(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
lcFirst (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphensToCamelCase (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName) Signal
signal
                                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
si Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
       ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ do
         let signalListType :: Text
signalListType = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "SignalList"
         Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
Text -> CodeGen ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ "type instance O.SignalList " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signalListType
         Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
Text -> CodeGen ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ "type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signalListType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = ('[ "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate ", " [Text]
infos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "] :: [(Symbol, *)])"

-- | Signal instances for interfaces.
genInterfaceSignals :: Name -> Interface -> CodeGen ()
genInterfaceSignals :: Name -> Interface -> CodeGen ()
genInterfaceSignals n :: Name
n iface :: Interface
iface = do
  let name :: Text
name = Name -> Text
upperName Name
n
  [Text]
infos <- Name -> Interface -> CodeGen [(Name, Signal)]
fullInterfaceSignalList Name
n Interface
iface BaseCodeGen e [(Name, Signal)]
-> ([(Name, Signal)]
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
           ((Name, Signal)
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [(Name, Signal)]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(owner :: Name
owner, signal :: Signal
signal) -> do
                   Text
si <- Name -> Signal -> CodeGen Text
signalInfoName Name
owner Signal
signal
                   Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "'(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
lcFirst (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphensToCamelCase (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName) Signal
signal
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
si Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
  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
    let signalListType :: Text
signalListType = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "SignalList"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type instance O.SignalList " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signalListType
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signalListType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = ('[ "
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate ", " [Text]
infos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "] :: [(Symbol, *)])"