-- 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/>.

{-# LANGUAGE CPP #-}

module Graphics.UI.Qtah.Generator.Module (
  AModule (..),
  aModuleHoppyModules,
  QtModule,
  makeQtModule,
  makeQtModuleWithVersionBounds,
  qtModulePath,
  qtModuleQtExports,
  qtModuleHoppy,
  ) where

import Control.Monad (unless)
import Control.Monad.Except (throwError)
import Data.Char (toLower)
import Data.Foldable (forM_)
import Data.List (find, intersperse, sort)
import Data.Maybe (isJust)
#if !MIN_VERSION_base(4,13,0)
import Data.Monoid (mconcat)
#endif
import Foreign.Hoppy.Generator.Language.Cpp (chunkContents, execChunkWriter, sayType)
import Foreign.Hoppy.Generator.Language.Haskell (
  Generator,
  HsTypeSide (HsHsSide),
  addExport,
  addExport',
  addExports,
  addExtension,
  addImports,
  askInterface,
  cppTypeToHsTypeAndUse,
  getClassHaskellConversion,
  getModuleForExtName,
  getModuleName,
  indent,
  inFunction,
  ln,
  prettyPrint,
  sayLn,
  saysLn,
  toHsFnName',
  )
import Foreign.Hoppy.Generator.Spec (
  Class,
  Constness (Const, Nonconst),
  Ctor,
  ExtName,
  FnName (FnName),
  ForeignLanguage (Haskell),
  Function,
  Method,
  MethodImpl (RealMethod),
  Module,
  Type,
  addAddendumHaskell,
  callbackParams,
  castExport,
  classCtors,
  classEntityForeignName,
  classExtName,
  classHaskellConversionFromCppFn,
  classHaskellConversionToCppFn,
  classMethods,
  ctorExtName,
  enumValueMapNames,
  fnExtName,
  fromExtName,
  getPrimaryExtName,
  hsImport1,
  hsImports,
  hsWholeModuleImport,
  makeModule,
  methodExtName,
  methodImpl,
  moduleAddExports,
  moduleAddHaskellName,
  moduleModify',
  parameterType,
  varGetterExtName,
  varIsConst,
  varSetterExtName,
  )
import Foreign.Hoppy.Generator.Spec.Callback (callbackT)
import Foreign.Hoppy.Generator.Spec.Class (
  toHsCastMethodName',
  toHsDataTypeName',
  toHsDownCastMethodName',
  toHsPtrClassName',
  toHsValueClassName',
  )
import Foreign.Hoppy.Generator.Spec.Enum (enumGetOverriddenEntryName, enumValues, toHsEnumTypeName')
import Foreign.Hoppy.Generator.Types (objT)
import Graphics.UI.Qtah.Generator.Config (Version, qrealFloat, qtVersion)
import Graphics.UI.Qtah.Generator.Common (fromMaybeM)
import Graphics.UI.Qtah.Generator.Flags (
  flagsEnum,
  toHsFlagsBindingName',
  toHsFlagsTypeName',
  toHsFlagsTypeclassName',
  )
import Graphics.UI.Qtah.Generator.Types (
  QtExport (
    QtExport,
    QtExportClassAndSignals,
    QtExportEvent,
    QtExportFnRenamed,
    QtExportSceneEvent,
    QtExportSpecials
  ),
  Signal,
  qtExportToExports,
  signalCallback,
  signalClass,
  signalCName,
  signalHaskellName,
  signalListenerClass,
  )
import Graphics.UI.Qtah.Generator.Interface.Imports
import Language.Haskell.Syntax (
  HsName (HsIdent),
  HsQName (UnQual),
  HsQualType (HsQualType),
  HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar),
  )

-- | A union of Hoppy and Qt modules.
data AModule = AHoppyModule Module | AQtModule QtModule

aModuleHoppyModules :: AModule -> [Module]
aModuleHoppyModules :: AModule -> [Module]
aModuleHoppyModules (AHoppyModule Module
m) = [Module
m]
aModuleHoppyModules (AQtModule QtModule
qm) = [QtModule -> Module
qtModuleHoppy QtModule
qm, QtModule -> Module
qtModuleHoppyWrapper QtModule
qm]

-- | A @QtModule@ (distinct from a Hoppy 'Module'), is a description of a
-- Haskell module in the @Graphics.UI.Qtah.Q@ namespace that:
--
--     1. reexports 'Export's from a Hoppy module, dropping @ClassName_@
--        prefixes from the reexported names.
--     2. generates Signal definitions for Qt signals.
data QtModule = QtModule
  { QtModule -> [ErrorMsg]
qtModulePath :: [String]
  , QtModule -> [QtExport]
qtModuleQtExports :: [QtExport]
    -- ^ A list of exports whose generated Hoppy bindings will be re-exported in
    -- this module.
  , QtModule -> Module
qtModuleHoppy :: Module
  , QtModule -> Module
qtModuleHoppyWrapper :: Module
  }

makeQtModule :: [String] -> [QtExport] -> QtModule
makeQtModule :: [ErrorMsg] -> [QtExport] -> QtModule
makeQtModule [] [QtExport]
_ = ErrorMsg -> QtModule
forall a. HasCallStack => ErrorMsg -> a
error ErrorMsg
"makeQtModule: Module path must be nonempty."
makeQtModule modulePath :: [ErrorMsg]
modulePath@(ErrorMsg
_:[ErrorMsg]
moduleNameParts) [QtExport]
qtExports =
  let lowerName :: ErrorMsg
lowerName = (Char -> Char) -> ErrorMsg -> ErrorMsg
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ErrorMsg -> ErrorMsg) -> ErrorMsg -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg]
moduleNameParts
  in QtModule
     { qtModulePath :: [ErrorMsg]
qtModulePath = [ErrorMsg]
modulePath
     , qtModuleQtExports :: [QtExport]
qtModuleQtExports = [QtExport]
qtExports
     , qtModuleHoppy :: Module
qtModuleHoppy =
       HasCallStack =>
Module -> StateT Module (Either ErrorMsg) () -> Module
Module -> StateT Module (Either ErrorMsg) () -> Module
moduleModify' (ErrorMsg -> ErrorMsg -> ErrorMsg -> Module
makeModule ErrorMsg
lowerName
                      ([ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"b_", ErrorMsg
lowerName, ErrorMsg
".hpp"])
                      ([ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"b_", ErrorMsg
lowerName, ErrorMsg
".cpp"])) (StateT Module (Either ErrorMsg) () -> Module)
-> StateT Module (Either ErrorMsg) () -> Module
forall a b. (a -> b) -> a -> b
$ do
         [ErrorMsg] -> StateT Module (Either ErrorMsg) ()
forall (m :: * -> *).
(MonadError ErrorMsg m, MonadState Module m) =>
[ErrorMsg] -> m ()
moduleAddHaskellName ([ErrorMsg] -> StateT Module (Either ErrorMsg) ())
-> [ErrorMsg] -> StateT Module (Either ErrorMsg) ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Generated" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: [ErrorMsg]
modulePath
         [Export] -> StateT Module (Either ErrorMsg) ()
forall (m :: * -> *).
(MonadError ErrorMsg m, MonadState Module m) =>
[Export] -> m ()
moduleAddExports ([Export] -> StateT Module (Either ErrorMsg) ())
-> [Export] -> StateT Module (Either ErrorMsg) ()
forall a b. (a -> b) -> a -> b
$ (QtExport -> [Export]) -> [QtExport] -> [Export]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap QtExport -> [Export]
qtExportToExports [QtExport]
qtExports
     , qtModuleHoppyWrapper :: Module
qtModuleHoppyWrapper =
       Generator () -> Module -> Module
forall a. HasAddendum a => Generator () -> a -> a
addAddendumHaskell ([ErrorMsg] -> [QtExport] -> Generator ()
sayWrapperModule [ErrorMsg]
modulePath [QtExport]
qtExports) (Module -> Module) -> Module -> Module
forall a b. (a -> b) -> a -> b
$
       HasCallStack =>
Module -> StateT Module (Either ErrorMsg) () -> Module
Module -> StateT Module (Either ErrorMsg) () -> Module
moduleModify' (ErrorMsg -> ErrorMsg -> ErrorMsg -> Module
makeModule (ErrorMsg
lowerName ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"wrap")
                      ([ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"b_", ErrorMsg
lowerName, ErrorMsg
"_w.hpp"])
                      ([ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"b_", ErrorMsg
lowerName, ErrorMsg
"_w.cpp"])) (StateT Module (Either ErrorMsg) () -> Module)
-> StateT Module (Either ErrorMsg) () -> Module
forall a b. (a -> b) -> a -> b
$
       [ErrorMsg] -> StateT Module (Either ErrorMsg) ()
forall (m :: * -> *).
(MonadError ErrorMsg m, MonadState Module m) =>
[ErrorMsg] -> m ()
moduleAddHaskellName [ErrorMsg]
modulePath
     }

-- | Creates a 'QtModule' (a la 'makeQtModule') that has lower or upper version
-- bounds applied to all of its contents.  If Qtah is being built against a
-- version of Qt outside of these bounds, then the module will still be
-- generated, but it will be empty; the exports list will be replaced with an
-- empty list.
--
-- Note that for the module's contents to be generated, the lower bound is
-- inclusive, it being the version in which the module was added.  The upper
-- bound is exclusive, being the version in which the module was removed.
--
-- We generate the module anyway to avoid having to conditionally include
-- modules in Cabal package definitions.
makeQtModuleWithVersionBounds :: [String]
                              -> Maybe Version
                              -- ^ The Qt version in which the module was added, if known.
                              -> Maybe Version
                              -- ^ The Qt version in which the module was removed, if known.
                              -> [QtExport]
                              -> QtModule
makeQtModuleWithVersionBounds :: [ErrorMsg]
-> Maybe Version -> Maybe Version -> [QtExport] -> QtModule
makeQtModuleWithVersionBounds [ErrorMsg]
modulePath Maybe Version
maybeAddedVersion Maybe Version
maybeRemovedVersion [QtExport]
qtExports =
  [ErrorMsg] -> [QtExport] -> QtModule
makeQtModule [ErrorMsg]
modulePath ([QtExport] -> QtModule) -> [QtExport] -> QtModule
forall a b. (a -> b) -> a -> b
$
  case Maybe Version
maybeAddedVersion of
    Just Version
addedVersion | Version
qtVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
addedVersion -> []
    Maybe Version
_ -> case Maybe Version
maybeRemovedVersion of
      Just Version
removedVersion | Version
qtVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
removedVersion -> []
      Maybe Version
_ -> [QtExport]
qtExports

sayWrapperModule :: [String] -> [QtExport] -> Generator ()
sayWrapperModule :: [ErrorMsg] -> [QtExport] -> Generator ()
sayWrapperModule [ErrorMsg]
modulePath [QtExport]
qtExports = ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
inFunction ErrorMsg
"<Qtah generateModule>" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  ErrorMsg -> Generator ()
addExtension ErrorMsg
"NoMonomorphismRestriction"

  -- As in generated Hoppy bindings, avoid non-qualified Prelude uses in
  -- generated code here.
  HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> [ErrorMsg] -> HsImportSet
hsImports ErrorMsg
"Prelude" []

  -- Import the underlying Hoppy module wholesale.
  case (QtExport -> [Export]) -> [QtExport] -> [Export]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap QtExport -> [Export]
qtExportToExports [QtExport]
qtExports of
    [] -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Export
export:[Export]
_ -> ExtName -> Generator ()
importWholeModuleForExtName (ExtName -> Generator ()) -> ExtName -> Generator ()
forall a b. (a -> b) -> a -> b
$ Export -> ExtName
forall a. HasExtNames a => a -> ExtName
getPrimaryExtName Export
export

  -- Generate bindings for all of the exports.
  (QtExport -> Generator ()) -> [QtExport] -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([ErrorMsg] -> QtExport -> Generator ()
sayQtExport [ErrorMsg]
modulePath) [QtExport]
qtExports

getFnImportName :: Function -> String
getFnImportName :: Function -> ErrorMsg
getFnImportName = ExtName -> ErrorMsg
toHsFnName' (ExtName -> ErrorMsg)
-> (Function -> ExtName) -> Function -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> ExtName
fnExtName

getFnReexportName :: Function -> String
getFnReexportName :: Function -> ErrorMsg
getFnReexportName = Function -> ErrorMsg
getFnImportName

classUpCastReexportName :: String
classUpCastReexportName :: ErrorMsg
classUpCastReexportName = ErrorMsg
"cast"

classUpCastConstReexportName :: String
classUpCastConstReexportName :: ErrorMsg
classUpCastConstReexportName = ErrorMsg
"castConst"

classDownCastReexportName :: String
classDownCastReexportName :: ErrorMsg
classDownCastReexportName = ErrorMsg
"downCast"

classDownCastConstReexportName :: String
classDownCastConstReexportName :: ErrorMsg
classDownCastConstReexportName = ErrorMsg
"downCastConst"

classEncodeReexportName :: String
classEncodeReexportName :: ErrorMsg
classEncodeReexportName = ErrorMsg
"encode"

classDecodeReexportName :: String
classDecodeReexportName :: ErrorMsg
classDecodeReexportName = ErrorMsg
"decode"

getCtorReexportName :: Ctor -> String
getCtorReexportName :: Ctor -> ErrorMsg
getCtorReexportName = ExtName -> ErrorMsg
toHsFnName' (ExtName -> ErrorMsg) -> (Ctor -> ExtName) -> Ctor -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctor -> ExtName
ctorExtName

getMethodReexportName :: Method -> String
getMethodReexportName :: Method -> ErrorMsg
getMethodReexportName = ExtName -> ErrorMsg
toHsFnName' (ExtName -> ErrorMsg) -> (Method -> ExtName) -> Method -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> ExtName
methodExtName

sayClassEncodingFnReexports :: Class -> Generator ()
sayClassEncodingFnReexports :: Class -> Generator ()
sayClassEncodingFnReexports Class
cls = ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
inFunction ErrorMsg
"sayClassEncodingFnReexports" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  let conv :: ClassHaskellConversion
conv = Class -> ClassHaskellConversion
getClassHaskellConversion Class
cls

  Maybe (Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionToCppFn ClassHaskellConversion
conv) ((Generator () -> Generator ()) -> Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator ()
_ -> do
    HsType
hsHsType <- HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
HsHsSide (Class -> Type
objT Class
cls)
    let dataTypeName :: ErrorMsg
dataTypeName = Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls
        ptrHsType :: HsType
ptrHsType = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
dataTypeName
        encodeFnType :: HsType
encodeFnType = HsType -> HsType -> HsType
HsTyFun HsType
hsHsType (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"QtahP.IO") HsType
ptrHsType
    HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
importForPrelude, HsImportSet
importForRuntime]
    Generator ()
ln
    [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
classEncodeReexportName, ErrorMsg
" :: ", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
prettyPrint HsType
encodeFnType]
    [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
classEncodeReexportName, ErrorMsg
" = QtahFHR.encodeAs (QtahP.undefined :: ", ErrorMsg
dataTypeName, ErrorMsg
")"]

  Maybe (Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionFromCppFn ClassHaskellConversion
conv) ((Generator () -> Generator ()) -> Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator ()
_ -> do
    HsType
hsHsType <- HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
HsHsSide (Class -> Type
objT Class
cls)
    let constPtrClassName :: ErrorMsg
constPtrClassName = Constness -> Class -> ErrorMsg
toHsPtrClassName' Constness
Const Class
cls
        thisTyVar :: HsType
thisTyVar = HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"this"
        decodeFnType :: HsQualType
decodeFnType = HsContext -> HsType -> HsQualType
HsQualType [(HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
constPtrClassName, [HsType
thisTyVar])] (HsType -> HsQualType) -> HsType -> HsQualType
forall a b. (a -> b) -> a -> b
$
                       HsType -> HsType -> HsType
HsTyFun HsType
thisTyVar (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$
                       HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"QtahP.IO") HsType
hsHsType
    HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
importForPrelude, HsImportSet
importForRuntime]
    Generator ()
ln
    [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
classDecodeReexportName, ErrorMsg
" :: ", HsQualType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
prettyPrint HsQualType
decodeFnType]
    [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
classDecodeReexportName, ErrorMsg
" = QtahFHR.decode QtahP.. ", Constness -> Class -> ErrorMsg
toHsCastMethodName' Constness
Const Class
cls]

handleEventKind :: [String] -> String -> Class -> Generator ()
handleEventKind :: [ErrorMsg] -> ErrorMsg -> Class -> Generator ()
handleEventKind [ErrorMsg]
path ErrorMsg
eventKind Class
cls = do
  let typeName :: ErrorMsg
typeName = Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls
  HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)"
  Generator ()
ln
  [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
"instance Qtah", ErrorMsg
eventKind, ErrorMsg
".", ErrorMsg
eventKind, ErrorMsg
" ", ErrorMsg
typeName, ErrorMsg
" where"]
  Generator () -> Generator ()
forall a. Generator a -> Generator a
indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
"on", ErrorMsg
eventKind, ErrorMsg
" receiver' handler' = Qtah", ErrorMsg
eventKind,
              ErrorMsg
".onAny", ErrorMsg
eventKind, ErrorMsg
" receiver' $ \\_ qevent' ->"]
    Generator () -> Generator ()
forall a. Generator a -> Generator a
indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      if [ErrorMsg]
path [ErrorMsg] -> [ErrorMsg] -> Bool
forall a. Eq a => a -> a -> Bool
== [ErrorMsg
"Core", ErrorMsg
"QEvent"]
      then ErrorMsg -> Generator ()
sayLn ErrorMsg
"handler' qevent'"
      else do
        HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(==)",
                              HsImportSet
importForPrelude,
                              HsImportSet
importForRuntime]
        [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
"let event' = ", ErrorMsg
classDownCastReexportName, ErrorMsg
" qevent'"]
        ErrorMsg -> Generator ()
sayLn ErrorMsg
"in if event' == QtahFHR.nullptr then QtahP.return QtahP.False else handler' event'"

sayQtExport :: [String] -> QtExport -> Generator ()
sayQtExport :: [ErrorMsg] -> QtExport -> Generator ()
sayQtExport [ErrorMsg]
path QtExport
qtExport = case QtExport
qtExport of
  QtExport Export
export -> Export -> Generator ()
forall {a}. Exportable a => a -> Generator ()
doExport Export
export

  QtExportFnRenamed Function
fn ErrorMsg
rename -> do
    ErrorMsg -> Generator ()
addExport ErrorMsg
rename
    ErrorMsg -> ErrorMsg -> Generator ()
sayBind ErrorMsg
rename (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Function -> ErrorMsg
getFnImportName Function
fn

  QtExportClassAndSignals Class
cls [Signal]
sigs -> do
    Class -> Generator ()
sayExportClass Class
cls
    (Signal -> Generator ()) -> [Signal] -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Signal -> Generator ()
sayExportSignal [Signal]
sigs

  QtExportEvent Class
cls -> do
    Class -> Generator ()
sayExportClass Class
cls

    HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
importForEvent, HsImportSet
importForSceneEvent]
    [ErrorMsg] -> ErrorMsg -> Class -> Generator ()
handleEventKind [ErrorMsg]
path ErrorMsg
"Event" Class
cls
    [ErrorMsg] -> ErrorMsg -> Class -> Generator ()
handleEventKind [ErrorMsg]
path ErrorMsg
"SceneEvent" Class
cls

  QtExportSceneEvent Class
cls -> do
    Class -> Generator ()
sayExportClass Class
cls

    HsImportSet -> Generator ()
addImports HsImportSet
importForSceneEvent
    [ErrorMsg] -> ErrorMsg -> Class -> Generator ()
handleEventKind [ErrorMsg]
path ErrorMsg
"SceneEvent" Class
cls

  QtExport
QtExportSpecials -> do
    -- Generate a type synonym for qreal.
    HsImportSet -> Generator ()
addImports HsImportSet
importForPrelude
    ErrorMsg -> Generator ()
addExport ErrorMsg
"QReal"
    Generator ()
ln
    [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
"type QReal = ", if Bool
qrealFloat then ErrorMsg
"QtahP.Float" else ErrorMsg
"QtahP.Double"]

  where doExport :: a -> Generator ()
doExport a
export = case a -> Maybe Class
forall b. (Typeable a, Exportable b, Typeable b) => a -> Maybe b
forall a b.
(Exportable a, Typeable a, Exportable b, Typeable b) =>
a -> Maybe b
castExport a
export of
          Just Class
c -> Class -> Generator ()
doExportClass Class
c
          Maybe Class
Nothing -> case a -> Maybe CppEnum
forall b. (Typeable a, Exportable b, Typeable b) => a -> Maybe b
forall a b.
(Exportable a, Typeable a, Exportable b, Typeable b) =>
a -> Maybe b
castExport a
export of
            Just CppEnum
e -> CppEnum -> Generator ()
doExportEnum CppEnum
e
            Maybe CppEnum
Nothing -> case a -> Maybe Flags
forall b. (Typeable a, Exportable b, Typeable b) => a -> Maybe b
forall a b.
(Exportable a, Typeable a, Exportable b, Typeable b) =>
a -> Maybe b
castExport a
export of
              Just Flags
flags -> Flags -> Generator ()
doExportFlags Flags
flags
              Maybe Flags
Nothing -> case a -> Maybe Function
forall b. (Typeable a, Exportable b, Typeable b) => a -> Maybe b
forall a b.
(Exportable a, Typeable a, Exportable b, Typeable b) =>
a -> Maybe b
castExport a
export of
                Just Function
f -> Function -> Generator ()
doExportFunction Function
f
                Maybe Function
Nothing -> case a -> Maybe Variable
forall b. (Typeable a, Exportable b, Typeable b) => a -> Maybe b
forall a b.
(Exportable a, Typeable a, Exportable b, Typeable b) =>
a -> Maybe b
castExport a
export of
                  Just Variable
v -> Variable -> Generator ()
doExportVariable Variable
v
                  Maybe Variable
Nothing -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        doExportClass :: Class -> Generator ()
doExportClass Class
cls = Class -> Generator ()
sayExportClass Class
cls

        doExportEnum :: CppEnum -> Generator ()
doExportEnum CppEnum
e = do
          let spec :: ErrorMsg
spec = CppEnum -> ErrorMsg
toHsEnumTypeName' CppEnum
e ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" (..)"
          ErrorMsg -> Generator ()
addExport ErrorMsg
spec

        doExportFlags :: Flags -> Generator ()
doExportFlags Flags
flags = do
          let enum :: CppEnum
enum = Flags -> CppEnum
flagsEnum Flags
flags
              typeName :: ErrorMsg
typeName = Flags -> ErrorMsg
toHsFlagsTypeName' Flags
flags
              typeclassName :: ErrorMsg
typeclassName = Flags -> ErrorMsg
toHsFlagsTypeclassName' Flags
flags
          -- Re-export the data type and typeclass.
          ErrorMsg -> Generator ()
addExport ErrorMsg
typeName
          ErrorMsg -> Generator ()
addExport' ErrorMsg
typeclassName
          -- Re-export the entries' bindings.
          [[ErrorMsg]] -> ([ErrorMsg] -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (EnumValueMap -> [[ErrorMsg]]
enumValueMapNames (EnumValueMap -> [[ErrorMsg]]) -> EnumValueMap -> [[ErrorMsg]]
forall a b. (a -> b) -> a -> b
$ CppEnum -> EnumValueMap
enumValues CppEnum
enum) (([ErrorMsg] -> Generator ()) -> Generator ())
-> ([ErrorMsg] -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \[ErrorMsg]
words -> do
            let words' :: [ErrorMsg]
words' = ForeignLanguage -> CppEnum -> [ErrorMsg] -> [ErrorMsg]
enumGetOverriddenEntryName ForeignLanguage
Haskell CppEnum
enum [ErrorMsg]
words
            ErrorMsg -> Generator ()
addExport (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Flags -> [ErrorMsg] -> ErrorMsg
toHsFlagsBindingName' Flags
flags [ErrorMsg]
words'

        doExportFunction :: Function -> Generator ()
doExportFunction Function
f = ErrorMsg -> Generator ()
addExport (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Function -> ErrorMsg
getFnReexportName Function
f

        doExportVariable :: Variable -> Generator ()
doExportVariable Variable
v = do
          ErrorMsg -> Generator ()
addExport (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
toHsFnName' (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Variable -> ExtName
varGetterExtName Variable
v
          Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Variable -> Bool
varIsConst Variable
v) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Generator ()
addExport (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
toHsFnName' (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Variable -> ExtName
varSetterExtName Variable
v

sayExportClass :: Class -> Generator ()
sayExportClass :: Class -> Generator ()
sayExportClass Class
cls = do
  [ErrorMsg] -> Generator ()
addExports ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$
    (Class -> ErrorMsg
toHsValueClassName' Class
cls ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" (..)") ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    (Constness -> Class -> ErrorMsg
toHsPtrClassName' Constness
Const Class
cls ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" (..)") ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    (Constness -> Class -> ErrorMsg
toHsPtrClassName' Constness
Nonconst Class
cls ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" (..)") ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Const Class
cls ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    ErrorMsg
classUpCastConstReexportName ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    ErrorMsg
classUpCastReexportName ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    ErrorMsg
classDownCastConstReexportName ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    ErrorMsg
classDownCastReexportName ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    [[ErrorMsg]] -> [ErrorMsg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ if Maybe (Generator ()) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Generator ()) -> Bool) -> Maybe (Generator ()) -> Bool
forall a b. (a -> b) -> a -> b
$ ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionToCppFn (ClassHaskellConversion -> Maybe (Generator ()))
-> ClassHaskellConversion -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ Class -> ClassHaskellConversion
getClassHaskellConversion Class
cls
             then [ErrorMsg
classEncodeReexportName]
             else []
           , if Maybe (Generator ()) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Generator ()) -> Bool) -> Maybe (Generator ()) -> Bool
forall a b. (a -> b) -> a -> b
$ ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionFromCppFn (ClassHaskellConversion -> Maybe (Generator ()))
-> ClassHaskellConversion -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ Class -> ClassHaskellConversion
getClassHaskellConversion Class
cls
             then [ErrorMsg
classDecodeReexportName]
             else []
           , [ErrorMsg] -> [ErrorMsg]
forall a. Ord a => [a] -> [a]
sort ([ErrorMsg] -> [ErrorMsg]) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ (Ctor -> ErrorMsg) -> [Ctor] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Ctor -> ErrorMsg
getCtorReexportName ([Ctor] -> [ErrorMsg]) -> [Ctor] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ Class -> [Ctor]
classCtors Class
cls
           , [ErrorMsg] -> [ErrorMsg]
forall a. Ord a => [a] -> [a]
sort ([ErrorMsg] -> [ErrorMsg]) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ (Method -> ErrorMsg) -> [Method] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Method -> ErrorMsg
getMethodReexportName ([Method] -> [ErrorMsg]) -> [Method] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ Class -> [Method]
classMethods Class
cls
           ]

  Generator ()
ln
  ErrorMsg -> ErrorMsg -> Generator ()
sayBind ErrorMsg
classUpCastConstReexportName (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsCastMethodName' Constness
Const Class
cls
  ErrorMsg -> ErrorMsg -> Generator ()
sayBind ErrorMsg
classUpCastReexportName (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsCastMethodName' Constness
Nonconst Class
cls
  ErrorMsg -> ErrorMsg -> Generator ()
sayBind ErrorMsg
classDownCastConstReexportName (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsDownCastMethodName' Constness
Const Class
cls
  ErrorMsg -> ErrorMsg -> Generator ()
sayBind ErrorMsg
classDownCastReexportName (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsDownCastMethodName' Constness
Nonconst Class
cls
  Class -> Generator ()
sayClassEncodingFnReexports Class
cls
  -- Class constructors and methods don't need to be rebound, because their
  -- names don't change.

-- | Generates and exports a @Signal@ definition.  We create the signal from
-- scratch in this module, rather than reexporting it from somewhere else.
sayExportSignal :: Signal -> Generator ()
sayExportSignal :: Signal -> Generator ()
sayExportSignal Signal
signal = ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
inFunction ErrorMsg
"sayExportSignal" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  let name :: ErrorMsg
name = Signal -> ErrorMsg
signalCName Signal
signal
      cls :: Class
cls = Signal -> Class
signalClass Signal
signal
      ptrClassName :: ErrorMsg
ptrClassName = Constness -> Class -> ErrorMsg
toHsPtrClassName' Constness
Nonconst Class
cls
      varName :: ErrorMsg
varName = Signal -> ErrorMsg
toSignalBindingName Signal
signal
  ErrorMsg -> Generator ()
addExport ErrorMsg
varName

  let listenerClass :: Class
listenerClass = Signal -> Class
signalListenerClass Signal
signal
  ExtName -> Generator ()
importWholeModuleForExtName (ExtName -> Generator ()) -> ExtName -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
listenerClass

  -- Find the listener constructor that only takes a callback.
  Ctor
listenerCtor <-
    ReaderT Env (WriterT Output (Except ErrorMsg)) Ctor
-> Maybe Ctor
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Ctor
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) Ctor
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) Ctor)
-> ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) Ctor
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ErrorMsg
"Couldn't find an appropriate ",
                ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
listenerClass),
                ErrorMsg
" constructor for signal ", ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ErrorMsg
name]) (Maybe Ctor -> ReaderT Env (WriterT Output (Except ErrorMsg)) Ctor)
-> Maybe Ctor
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Ctor
forall a b. (a -> b) -> a -> b
$
    ((Ctor -> Bool) -> [Ctor] -> Maybe Ctor)
-> [Ctor] -> (Ctor -> Bool) -> Maybe Ctor
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Ctor -> Bool) -> [Ctor] -> Maybe Ctor
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Class -> [Ctor]
classCtors Class
listenerClass) ((Ctor -> Bool) -> Maybe Ctor) -> (Ctor -> Bool) -> Maybe Ctor
forall a b. (a -> b) -> a -> b
$ \Ctor
ctor -> ExtName -> ErrorMsg
fromExtName (Ctor -> ExtName
ctorExtName Ctor
ctor) ErrorMsg -> ErrorMsg -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorMsg
"new"
  let callback :: Callback
callback = Signal -> Callback
signalCallback Signal
signal
      paramTypes :: [Type]
paramTypes = (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType ([Parameter] -> [Type]) -> [Parameter] -> [Type]
forall a b. (a -> b) -> a -> b
$ Callback -> [Parameter]
callbackParams Callback
callback

  -- Also find the 'isValid' method.
  Method
isValidMethod <-
    ReaderT Env (WriterT Output (Except ErrorMsg)) Method
-> Maybe Method
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Method
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) Method
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) Method)
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Method
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ErrorMsg
"Couldn't find the isValid method in ",
                 Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
listenerClass, ErrorMsg
" for signal ", ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ErrorMsg
name]) (Maybe Method
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) Method)
-> Maybe Method
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Method
forall a b. (a -> b) -> a -> b
$
    (Method -> Bool) -> [Method] -> Maybe Method
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FnName ErrorMsg -> MethodImpl
RealMethod (ErrorMsg -> FnName ErrorMsg
forall name. name -> FnName name
FnName ErrorMsg
"isValid") MethodImpl -> MethodImpl -> Bool
forall a. Eq a => a -> a -> Bool
==) (MethodImpl -> Bool) -> (Method -> MethodImpl) -> Method -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> MethodImpl
methodImpl) ([Method] -> Maybe Method) -> [Method] -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Class -> [Method]
classMethods Class
listenerClass

  HsType
callbackHsType <- HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
HsHsSide (Type -> Generator HsType) -> Type -> Generator HsType
forall a b. (a -> b) -> a -> b
$ Callback -> Type
callbackT Callback
callback

  let varType :: HsQualType
varType = HsContext -> HsType -> HsQualType
HsQualType [(HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
ptrClassName, [HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"object"])] (HsType -> HsQualType) -> HsType -> HsQualType
forall a b. (a -> b) -> a -> b
$
                HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"QtahSignal.Signal") (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$
                         HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"object")
                HsType
callbackHsType
      internalName :: ErrorMsg
internalName = [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                     [ ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
cls
                     , ErrorMsg
"::"
                     , ErrorMsg
name
                     , ErrorMsg
" ("
                     , ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
listenerClass
                     , ErrorMsg
")"
                     ]

  HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> [ErrorMsg] -> HsImportSet
hsImports ErrorMsg
"Prelude" [ErrorMsg
"($)", ErrorMsg
"(>>)"],
                        HsImportSet
importForPrelude,
                        HsImportSet
importForRuntime,
                        HsImportSet
importForSignal]
  Generator ()
ln
  [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
varName, ErrorMsg
" :: ", HsQualType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
prettyPrint HsQualType
varType]
  [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
varName, ErrorMsg
" = QtahSignal.Signal"]
  Generator () -> Generator ()
forall a. Generator a -> Generator a
indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    ErrorMsg -> Generator ()
sayLn ErrorMsg
"{ QtahSignal.internalConnectSignal = \\object' fn' -> do"
    Generator () -> Generator ()
forall a. Generator a -> Generator a
indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
      [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
"listener' <- ",
              ExtName -> ErrorMsg
toHsFnName' (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> Ctor -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
listenerClass Ctor
listenerCtor,
              ErrorMsg
" object' ",
              ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Signal -> [Type] -> ErrorMsg
toSignalConnectName Signal
signal [Type]
paramTypes),
              ErrorMsg
" fn'"]
      [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
"valid' <- ",
              ExtName -> ErrorMsg
toHsFnName' (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
listenerClass Method
isValidMethod,
              ErrorMsg
" listener'"]
      ErrorMsg -> Generator ()
sayLn ErrorMsg
"if valid'"
      Generator () -> Generator ()
forall a. Generator a -> Generator a
indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        ErrorMsg -> Generator ()
sayLn ErrorMsg
"then QtahP.fmap QtahP.Just $ QtahSignal.internalMakeConnection listener'"
        ErrorMsg -> Generator ()
sayLn ErrorMsg
"else QtahFHR.delete listener' >> QtahP.return QtahP.Nothing"
    [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
", QtahSignal.internalName = ", ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ErrorMsg
internalName]
    ErrorMsg -> Generator ()
sayLn ErrorMsg
"}"

sayBind :: String -> String -> Generator ()
sayBind :: ErrorMsg -> ErrorMsg -> Generator ()
sayBind ErrorMsg
name ErrorMsg
value = [ErrorMsg] -> Generator ()
saysLn [ErrorMsg
name, ErrorMsg
" = ", ErrorMsg
value]

toSignalBindingName :: Signal -> String
toSignalBindingName :: Signal -> ErrorMsg
toSignalBindingName = (ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"Signal") (ErrorMsg -> ErrorMsg)
-> (Signal -> ErrorMsg) -> Signal -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> ErrorMsg
signalHaskellName

toSignalConnectName :: Signal -> [Type] -> String
toSignalConnectName :: Signal -> [Type] -> ErrorMsg
toSignalConnectName Signal
signal [Type]
paramTypes =
  [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ErrorMsg] -> ErrorMsg) -> [ErrorMsg] -> ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ErrorMsg
"2" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:  -- This is a magic code added by the SIGNAL() macro.
  Signal -> ErrorMsg
signalCName Signal
signal ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
  ErrorMsg
"(" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
  ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
intersperse ErrorMsg
"," ((Type -> ErrorMsg) -> [Type] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (Chunk -> ErrorMsg
chunkContents (Chunk -> ErrorMsg) -> (Type -> Chunk) -> Type -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer [Chunk] () -> Chunk
forall a. Writer [Chunk] a -> Chunk
execChunkWriter (Writer [Chunk] () -> Chunk)
-> (Type -> Writer [Chunk] ()) -> Type -> Chunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [ErrorMsg] -> Type -> Writer [Chunk] ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [ErrorMsg] -> Type -> m ()
sayType Maybe [ErrorMsg]
forall a. Maybe a
Nothing) [Type]
paramTypes) [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++
  [ErrorMsg
")"]

importWholeModuleForExtName :: ExtName -> Generator ()
importWholeModuleForExtName :: ExtName -> Generator ()
importWholeModuleForExtName ExtName
extName = do
  Interface
iface <- Generator Interface
askInterface
  HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ())
-> (Module -> HsImportSet) -> Module -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> HsImportSet
hsWholeModuleImport (ErrorMsg -> HsImportSet)
-> (Module -> ErrorMsg) -> Module -> HsImportSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Module -> ErrorMsg
getModuleName Interface
iface (Module -> Generator ())
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Module
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExtName -> ReaderT Env (WriterT Output (Except ErrorMsg)) Module
getModuleForExtName ExtName
extName