-- This file is part of Qtah.
--
-- Copyright 2015-2023 The Qtah Authors.
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Lesser General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Graphics.UI.Qtah.Generator.Types (
  QtExport (..),
  qtExport,
  qtExportToExports,
  makeQtEnum,
  makeQtEnum',
  makeQtEnumAndFlags,
  makeQtEnumAndFlags',
  makeQtEnumAndFlagsWithOverrides,
  ListenerInfo (ListenerInfo),
  Signal, SignalGen, makeSignal, makeSignal', makeSignalPrivate,
  makeQtClassAndSignals,
  signalCName, signalHaskellName, signalClass, signalListenerClass, signalCallback,
  ) where

import Data.Maybe (mapMaybe)
import qualified Data.Set as S
import Foreign.Hoppy.Generator.Spec (
  Callback,
  Class,
  ClassEntity (CEMethod),
  CppEnum,
  Scoped (Unscoped),
  Export (Export),
  Exportable,
  ForeignLanguage (Haskell),
  Function,
  Identifier,
  Include,
  addReqIncludes,
  callbackParams,
  callbackReturn,
  classAddEntities,
  enumAddEntryNameOverrides,
  enumSetHasBitOperations,
  enumSetUnknownValueEntry,
  enumSetValuePrefix,
  identifierParts,
  idPartBase,
  makeAutoEnum,
  mkMethod'_,
  onParameterType,
  stripToGc,
  toExtName,
  toExport,
  )
import Graphics.UI.Qtah.Generator.Common (upperFirst)
import Graphics.UI.Qtah.Generator.Flags (Flags, makeFlags)

data QtExport =
  QtExport Export
  | QtExportFnRenamed Function String
  | QtExportClassAndSignals Class [Signal]
    -- ^ Exports a class together with signals that belong to it.  These signals
    -- should have been constructed with 'makeQtClassAndSignals' so that the
    -- class has manual emit methods.
  | QtExportEvent Class
  | QtExportSceneEvent Class
  | QtExportSpecials
    -- ^ This is a special value that is exported exactly once, and generates
    -- some bindings that need special logic.

qtExport :: Exportable a => a -> QtExport
qtExport :: forall a. Exportable a => a -> QtExport
qtExport = Export -> QtExport
QtExport (Export -> QtExport) -> (a -> Export) -> a -> QtExport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Export
forall a. Exportable a => a -> Export
toExport

qtExportToExports :: QtExport -> [Export]
qtExportToExports :: QtExport -> [Export]
qtExportToExports QtExport
qtExport = case QtExport
qtExport of
  QtExport Export
export -> [Export
export]
  QtExportFnRenamed Function
fn [Char]
_ -> [Function -> Export
forall a. Exportable a => a -> Export
Export Function
fn]
  QtExportClassAndSignals Class
cls [Signal]
_ -> [Class -> Export
forall a. Exportable a => a -> Export
Export Class
cls]
  QtExportEvent Class
cls -> [Class -> Export
forall a. Exportable a => a -> Export
Export Class
cls]
  QtExportSceneEvent Class
cls -> [Class -> Export
forall a. Exportable a => a -> Export
Export Class
cls]
  QtExport
QtExportSpecials -> []

-- | Creates a 'CppEnum' whose 'ExtName' is the concatenation of all part of its
-- 'Identifier'.  This should be used for all Qt enums.
makeQtEnum :: Identifier -> [Include] -> [String] -> CppEnum
makeQtEnum :: Identifier -> [Include] -> [[Char]] -> CppEnum
makeQtEnum Identifier
identifier [Include]
includes [[Char]]
names =
  Identifier -> Scoped -> [Include] -> [[Char]] -> CppEnum
makeQtEnum' Identifier
identifier
              Scoped
Unscoped  -- Most Qt enums are unscoped.
              [Include]
includes
              [[Char]]
names

-- | Creates a 'CppEnum' like 'makeQtEnum' does, but also takes a boolean
-- parameter indicating whether the enum is scoped.
makeQtEnum' :: Identifier -> Scoped -> [Include] -> [String] -> CppEnum
makeQtEnum' :: Identifier -> Scoped -> [Include] -> [[Char]] -> CppEnum
makeQtEnum' Identifier
identifier Scoped
scoped [Include]
includes [[Char]]
names =
  [Include] -> CppEnum -> CppEnum
forall a. HasReqs a => [Include] -> a -> a
addReqIncludes [Include]
includes (CppEnum -> CppEnum) -> CppEnum -> CppEnum
forall a b. (a -> b) -> a -> b
$
  [Char] -> CppEnum -> CppEnum
enumSetValuePrefix [Char]
"" (CppEnum -> CppEnum) -> CppEnum -> CppEnum
forall a b. (a -> b) -> a -> b
$
  [Char] -> CppEnum -> CppEnum
forall a. IsEnumUnknownValueEntry a => a -> CppEnum -> CppEnum
enumSetUnknownValueEntry ([Char]
"Unknown" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
niceName) (CppEnum -> CppEnum) -> CppEnum -> CppEnum
forall a b. (a -> b) -> a -> b
$
  Bool -> CppEnum -> CppEnum
enumSetHasBitOperations Bool
False (CppEnum -> CppEnum) -> CppEnum -> CppEnum
forall a b. (a -> b) -> a -> b
$
  CppEnum -> CppEnum
addEntryOverrides (CppEnum -> CppEnum) -> CppEnum -> CppEnum
forall a b. (a -> b) -> a -> b
$
  Identifier -> Maybe ExtName -> Scoped -> [[Char]] -> CppEnum
forall v.
IsAutoEnumValue v =>
Identifier -> Maybe ExtName -> Scoped -> [v] -> CppEnum
makeAutoEnum Identifier
identifier
               (ExtName -> Maybe ExtName
forall a. a -> Maybe a
Just (ExtName -> Maybe ExtName) -> ExtName -> Maybe ExtName
forall a b. (a -> b) -> a -> b
$ HasCallStack => [Char] -> ExtName
[Char] -> ExtName
toExtName [Char]
niceName)
               Scoped
scoped
               [[Char]]
names
  where niceName :: [Char]
niceName = (IdPart -> [Char]) -> [IdPart] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IdPart -> [Char]
idPartBase ([IdPart] -> [Char]) -> [IdPart] -> [Char]
forall a b. (a -> b) -> a -> b
$ Identifier -> [IdPart]
identifierParts Identifier
identifier
        addEntryOverrides :: CppEnum -> CppEnum
addEntryOverrides = ForeignLanguage -> [([Char], [Char])] -> CppEnum -> CppEnum
forall v.
IsAutoEnumValue v =>
ForeignLanguage -> [(v, v)] -> CppEnum -> CppEnum
enumAddEntryNameOverrides ForeignLanguage
Haskell [([Char], [Char])]
applicableOverrides
        applicableOverrides :: [([Char], [Char])]
applicableOverrides = (([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [([Char], [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([Char]
from, [Char]
_) -> [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member [Char]
from Set [Char]
nameSet) [([Char], [Char])]
enumNameOverrides
        nameSet :: Set [Char]
nameSet = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
S.fromList [[Char]]
names

-- | Creates a 'CppEnum' and 'Flags' pair, with the same entries and related
-- names.
makeQtEnumAndFlags :: Identifier -> String -> [Include] -> [String] -> (CppEnum, Flags)
makeQtEnumAndFlags :: Identifier -> [Char] -> [Include] -> [[Char]] -> (CppEnum, Flags)
makeQtEnumAndFlags Identifier
enumIdentifier [Char]
flagsName [Include]
includes [[Char]]
names =
  let enum :: CppEnum
enum = Identifier -> [Include] -> [[Char]] -> CppEnum
makeQtEnum Identifier
enumIdentifier [Include]
includes [[Char]]
names
      flags :: Flags
flags = CppEnum -> [Char] -> Flags
makeFlags CppEnum
enum [Char]
flagsName
  in (CppEnum
enum, Flags
flags)

-- | Creates a 'CppEnum' and 'Flags' pair like 'makeQtEnumAndFlags' does, but
-- also takes a boolean parameter indicating whether the enum is scoped.
makeQtEnumAndFlags' :: Identifier -> String -> Scoped -> [Include] -> [String] -> (CppEnum, Flags)
makeQtEnumAndFlags' :: Identifier
-> [Char] -> Scoped -> [Include] -> [[Char]] -> (CppEnum, Flags)
makeQtEnumAndFlags' Identifier
enumIdentifier [Char]
flagsName Scoped
scoped [Include]
includes [[Char]]
names =
  let enum :: CppEnum
enum = Identifier -> Scoped -> [Include] -> [[Char]] -> CppEnum
makeQtEnum' Identifier
enumIdentifier Scoped
scoped [Include]
includes [[Char]]
names
      flags :: Flags
flags = CppEnum -> [Char] -> Flags
makeFlags CppEnum
enum [Char]
flagsName
  in (CppEnum
enum, Flags
flags)

-- | This version of 'makeQtEnumAndFlags' accepts entry name overrides, which is
-- useful because flag bindings can conflict with method names (they're both
-- Haskell identifiers starting with lower-case letters).
makeQtEnumAndFlagsWithOverrides ::
  Identifier -> String -> [Include] -> [String] -> [(String, String)] -> (CppEnum, Flags)
makeQtEnumAndFlagsWithOverrides :: Identifier
-> [Char]
-> [Include]
-> [[Char]]
-> [([Char], [Char])]
-> (CppEnum, Flags)
makeQtEnumAndFlagsWithOverrides Identifier
enumIdentifier [Char]
flagsName [Include]
includes [[Char]]
names [([Char], [Char])]
nameOverrides =
  let enum :: CppEnum
enum = ForeignLanguage -> [([Char], [Char])] -> CppEnum -> CppEnum
forall v.
IsAutoEnumValue v =>
ForeignLanguage -> [(v, v)] -> CppEnum -> CppEnum
enumAddEntryNameOverrides ForeignLanguage
Haskell [([Char], [Char])]
nameOverrides (CppEnum -> CppEnum) -> CppEnum -> CppEnum
forall a b. (a -> b) -> a -> b
$
             Identifier -> [Include] -> [[Char]] -> CppEnum
makeQtEnum Identifier
enumIdentifier [Include]
includes [[Char]]
names
      flags :: Flags
flags = CppEnum -> [Char] -> Flags
makeFlags CppEnum
enum [Char]
flagsName
  in (CppEnum
enum, Flags
flags)

-- | Global enum entry name overrides.  These are applied to all enum entries,
-- to handle the cases where they overlap with Haskell keywords.
--
-- TODO Fill these out based on enums we're defined so far.
enumNameOverrides :: [(String, String)]
enumNameOverrides :: [([Char], [Char])]
enumNameOverrides =
  [ ([Char]
"Type", [Char]
"Typ")
  ]

-- | Specification for a signal in the Qt signals and slots framework.
data Signal = Signal
  { Signal -> Class
signalClass :: Class
    -- ^ The class to which the signal belongs.
  , Signal -> [Char]
signalCName :: String
    -- ^ The C name of the signal, without parameters, e.g. @"clicked"@.
  , Signal -> [Char]
signalHaskellName :: String
    -- ^ The base name of the Haskell binding for the signal.  Normally the same
    -- as the C name.
  , Signal -> Class
signalListenerClass :: Class
    -- ^ An appropriately typed listener class.
  , Signal -> Callback
signalCallback :: Callback
    -- ^ The callback type used by the listener.
  , Signal -> Bool
signalPrivate :: Bool
    -- ^ Most signals can both be connected to and emitted by the user.
    -- @QObject::objectNameChanged@ for example is a \"private signal,\" which
    -- can be connected to but not emitted manually.  For such signals, this
    -- field is true.
  }

-- | A curried function for constructing a signal that only needs the class that
-- the signal belongs to.
type SignalGen = Class -> Signal

data ListenerInfo = ListenerInfo Class Callback

-- The class is the last argument to these makeSignal functions because it is
-- curried; see qtExportClassAndSignals.

-- TODO Docs here.

-- | Constructs a signal for use with 'qtExportClassAndSignals'.  The signal can
-- be listened for via Haskell callback functions.  The constructed signal is
-- public: an "emit" method will also be added to the class for manually
-- emitting the signal.
--
-- The first argument is used both as the signal's C++ name, and the name it
-- will be given in Haskell.
makeSignal :: String  -- ^ 'signalCName'
           -> ListenerInfo  -- ^ 'signalListenerClass' and 'signalCallback'.
           -> SignalGen  -- ^ Curried function to take 'signalClass' and return the signal.
makeSignal :: [Char] -> ListenerInfo -> SignalGen
makeSignal [Char]
cName (ListenerInfo Class
listenerClass Callback
callback) Class
cls =
  Class -> [Char] -> [Char] -> Class -> Callback -> Bool -> Signal
Signal Class
cls [Char]
cName [Char]
cName Class
listenerClass Callback
callback Bool
False

-- | Constructs a signal for use with 'qtExportClassAndSignals', as 'makeSignal'
-- does, except separate C++ and Haskell names may be provided.
--
-- The first argument is used both as the signal's C++ name, and the second
-- argument is the name it will be given in Haskell.  This is analogous to
-- @mkMethod@ and @mkMethod'@.
makeSignal' :: String  -- ^ 'signalCName'
            -> String  -- ^ 'signalHaskellName'
            -> ListenerInfo  -- ^ 'signalListenerClass' and 'signalCallback'.
            -> SignalGen  -- ^ Curried function to take 'signalClass' and return the signal.
makeSignal' :: [Char] -> [Char] -> ListenerInfo -> SignalGen
makeSignal' [Char]
cName [Char]
hsName (ListenerInfo Class
listenerClass Callback
callback) Class
cls =
  Class -> [Char] -> [Char] -> Class -> Callback -> Bool -> Signal
Signal Class
cls [Char]
cName [Char]
hsName Class
listenerClass Callback
callback Bool
False

-- | Constructs a signal for use with 'qtExportClassAndSignals', as 'makeSignal'
-- does, except the constructed signal is private: no "emit" method is added to
-- the class for manually emitting the signal.
makeSignalPrivate ::
     String  -- ^ 'signalCName'
  -> ListenerInfo  -- ^ 'signalListenerClass' and 'signalCallback'.
  -> SignalGen  -- ^ Curried function to take 'signalClass' and return the signal.
makeSignalPrivate :: [Char] -> ListenerInfo -> SignalGen
makeSignalPrivate [Char]
cName (ListenerInfo Class
listenerClass Callback
callback) Class
cls =
  Class -> [Char] -> [Char] -> Class -> Callback -> Bool -> Signal
Signal Class
cls [Char]
cName [Char]
cName Class
listenerClass Callback
callback Bool
True

-- | Combines a class with signals that belong to it.  'SignalGen' values are
-- combined with the class to produce 'Signal's, and methods for emitting
-- (public) signals manually are added in the returned class.
makeQtClassAndSignals :: [SignalGen] -> Class -> (Class, [Signal])
makeQtClassAndSignals :: [SignalGen] -> Class -> (Class, [Signal])
makeQtClassAndSignals [SignalGen]
sigs Class
cls = (Class
cls', [Signal]
sigs')
  where cls' :: Class
cls' = ([ClassEntity] -> Class -> Class)
-> Class -> [ClassEntity] -> Class
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ClassEntity] -> Class -> Class
classAddEntities Class
cls ([ClassEntity] -> Class) -> [ClassEntity] -> Class
forall a b. (a -> b) -> a -> b
$ ((Signal -> Maybe ClassEntity) -> [Signal] -> [ClassEntity])
-> [Signal] -> (Signal -> Maybe ClassEntity) -> [ClassEntity]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Signal -> Maybe ClassEntity) -> [Signal] -> [ClassEntity]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Signal]
sigs' ((Signal -> Maybe ClassEntity) -> [ClassEntity])
-> (Signal -> Maybe ClassEntity) -> [ClassEntity]
forall a b. (a -> b) -> a -> b
$ \Signal
sig ->
          if Signal -> Bool
signalPrivate Signal
sig
          then Maybe ClassEntity
forall a. Maybe a
Nothing
          else ClassEntity -> Maybe ClassEntity
forall a. a -> Maybe a
Just (ClassEntity -> Maybe ClassEntity)
-> ClassEntity -> Maybe ClassEntity
forall a b. (a -> b) -> a -> b
$
               let cName :: [Char]
cName = Signal -> [Char]
signalCName Signal
sig
                   -- We prepend "emit" to the name of the Haskell method to make it clear
                   -- that it emits a signal, and to avoid collisions with other
                   -- namespaces that are distinct in C++ but shared in Haskell.  For
                   -- example, QAbstractItemView::DoubleClicked produces a 'doubleClicked'
                   -- Haskell binding; without this prefix, we would also try to generate
                   -- a method with that name.
                   hsName :: [Char]
hsName = [Char]
"emit" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
upperFirst (Signal -> [Char]
signalHaskellName Signal
sig)
                   callback :: Callback
callback = Signal -> Callback
signalCallback Signal
sig
                   -- We have to strip toGcT off of callback parameters.  It makes sense
                   -- in callback arguments because we can have the GC manage objects the
                   -- signal listener receives, but it doesn't make sense when passing
                   -- objects *to* a manual signal emit call.  See for example
                   -- cb_QModelIndexQModelIndexQVectorIntVoid.
                   params :: [Parameter]
params = (Parameter -> Parameter) -> [Parameter] -> [Parameter]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> Parameter -> Parameter
onParameterType Type -> Type
stripToGc) ([Parameter] -> [Parameter]) -> [Parameter] -> [Parameter]
forall a b. (a -> b) -> a -> b
$ Callback -> [Parameter]
callbackParams Callback
callback
                   retType :: Type
retType = Callback -> Type
callbackReturn Callback
callback
               in Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> Method -> ClassEntity
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Parameter] -> Type -> Method
forall name p.
(IsFnName [Char] name, IsParameter p) =>
name -> [Char] -> [p] -> Type -> Method
mkMethod'_ [Char]
cName [Char]
hsName [Parameter]
params Type
retType

        sigs' :: [Signal]
sigs' = (SignalGen -> Signal) -> [SignalGen] -> [Signal]
forall a b. (a -> b) -> [a] -> [b]
map (SignalGen -> SignalGen
forall a b. (a -> b) -> a -> b
$ Class
cls') [SignalGen]
sigs