-- This file is part of Qtah.
--
-- Copyright 2015-2021 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,
  makeQtModuleWithMinVersion,
  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 -> [String]
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 :: [String] -> [QtExport] -> QtModule
makeQtModule [] [QtExport]
_ = String -> QtModule
forall a. HasCallStack => String -> a
error String
"makeQtModule: Module path must be nonempty."
makeQtModule modulePath :: [String]
modulePath@(String
_:[String]
moduleNameParts) [QtExport]
qtExports =
  let lowerName :: String
lowerName = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
moduleNameParts
  in QtModule :: [String] -> [QtExport] -> Module -> Module -> QtModule
QtModule
     { qtModulePath :: [String]
qtModulePath = [String]
modulePath
     , qtModuleQtExports :: [QtExport]
qtModuleQtExports = [QtExport]
qtExports
     , qtModuleHoppy :: Module
qtModuleHoppy =
       HasCallStack =>
Module -> StateT Module (Either String) () -> Module
Module -> StateT Module (Either String) () -> Module
moduleModify' (String -> String -> String -> Module
makeModule String
lowerName
                      ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"b_", String
lowerName, String
".hpp"])
                      ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"b_", String
lowerName, String
".cpp"])) (StateT Module (Either String) () -> Module)
-> StateT Module (Either String) () -> Module
forall a b. (a -> b) -> a -> b
$ do
         [String] -> StateT Module (Either String) ()
forall (m :: * -> *).
(MonadError String m, MonadState Module m) =>
[String] -> m ()
moduleAddHaskellName ([String] -> StateT Module (Either String) ())
-> [String] -> StateT Module (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"Generated" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
modulePath
         [Export] -> StateT Module (Either String) ()
forall (m :: * -> *).
(MonadError String m, MonadState Module m) =>
[Export] -> m ()
moduleAddExports ([Export] -> StateT Module (Either String) ())
-> [Export] -> StateT Module (Either String) ()
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 ([String] -> [QtExport] -> Generator ()
sayWrapperModule [String]
modulePath [QtExport]
qtExports) (Module -> Module) -> Module -> Module
forall a b. (a -> b) -> a -> b
$
       HasCallStack =>
Module -> StateT Module (Either String) () -> Module
Module -> StateT Module (Either String) () -> Module
moduleModify' (String -> String -> String -> Module
makeModule (String
lowerName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"wrap")
                      ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"b_", String
lowerName, String
"_w.hpp"])
                      ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"b_", String
lowerName, String
"_w.cpp"])) (StateT Module (Either String) () -> Module)
-> StateT Module (Either String) () -> Module
forall a b. (a -> b) -> a -> b
$
       [String] -> StateT Module (Either String) ()
forall (m :: * -> *).
(MonadError String m, MonadState Module m) =>
[String] -> m ()
moduleAddHaskellName [String]
modulePath
     }

-- | Creates a 'QtModule' (a la 'makeQtModule') that has a minimum version
-- applied to all of its contents.  If Qtah is being built against a version of
-- Qt below this minimum version, then the module will still be generated, but
-- it will be empty; the exports list will be replaced with an empty list.
makeQtModuleWithMinVersion :: [String] -> Version -> [QtExport] -> QtModule
makeQtModuleWithMinVersion :: [String] -> Version -> [QtExport] -> QtModule
makeQtModuleWithMinVersion [String]
modulePath Version
minVersion [QtExport]
qtExports =
  [String] -> [QtExport] -> QtModule
makeQtModule [String]
modulePath ([QtExport] -> QtModule) -> [QtExport] -> QtModule
forall a b. (a -> b) -> a -> b
$
  if Version
qtVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
minVersion then [QtExport]
qtExports else []

sayWrapperModule :: [String] -> [QtExport] -> Generator ()
sayWrapperModule :: [String] -> [QtExport] -> Generator ()
sayWrapperModule [String]
modulePath [QtExport]
qtExports = String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
inFunction String
"<Qtah generateModule>" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  String -> Generator ()
addExtension String
"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
$ String -> [String] -> HsImportSet
hsImports String
"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 (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_ ([String] -> QtExport -> Generator ()
sayQtExport [String]
modulePath) [QtExport]
qtExports

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

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

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

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

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

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

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

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

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

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

sayClassEncodingFnReexports :: Class -> Generator ()
sayClassEncodingFnReexports :: Class -> Generator ()
sayClassEncodingFnReexports Class
cls = String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
inFunction String
"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 :: String
dataTypeName = Constness -> Class -> String
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
$ String -> HsName
HsIdent String
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
$ String -> HsName
HsIdent String
"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
    [String] -> Generator ()
saysLn [String
classEncodeReexportName, String
" :: ", HsType -> String
forall a. Pretty a => a -> String
prettyPrint HsType
encodeFnType]
    [String] -> Generator ()
saysLn [String
classEncodeReexportName, String
" = QtahFHR.encodeAs (QtahP.undefined :: ", String
dataTypeName, String
")"]

  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 :: String
constPtrClassName = Constness -> Class -> String
toHsPtrClassName' Constness
Const Class
cls
        thisTyVar :: HsType
thisTyVar = HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"this"
        decodeFnType :: HsQualType
decodeFnType = HsContext -> HsType -> HsQualType
HsQualType [(HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
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
$ String -> HsName
HsIdent String
"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
    [String] -> Generator ()
saysLn [String
classDecodeReexportName, String
" :: ", HsQualType -> String
forall a. Pretty a => a -> String
prettyPrint HsQualType
decodeFnType]
    [String] -> Generator ()
saysLn [String
classDecodeReexportName, String
" = QtahFHR.decode QtahP.. ", Constness -> Class -> String
toHsCastMethodName' Constness
Const Class
cls]

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

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

  QtExportFnRenamed Function
fn String
rename -> do
    String -> Generator ()
addExport String
rename
    String -> String -> Generator ()
sayBind String
rename (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Function -> String
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]
    [String] -> String -> Class -> Generator ()
handleEventKind [String]
path String
"Event" Class
cls
    [String] -> String -> Class -> Generator ()
handleEventKind [String]
path String
"SceneEvent" Class
cls

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

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

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

  where doExport :: a -> Generator ()
doExport a
export = case a -> Maybe Class
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 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 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 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 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 (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 :: String
spec = CppEnum -> String
toHsEnumTypeName' CppEnum
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (..)"
          String -> Generator ()
addExport String
spec

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

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

        doExportVariable :: Variable -> Generator ()
doExportVariable Variable
v = do
          String -> Generator ()
addExport (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ ExtName -> String
toHsFnName' (ExtName -> String) -> ExtName -> String
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
$ String -> Generator ()
addExport (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ ExtName -> String
toHsFnName' (ExtName -> String) -> ExtName -> String
forall a b. (a -> b) -> a -> b
$ Variable -> ExtName
varSetterExtName Variable
v

sayExportClass :: Class -> Generator ()
sayExportClass :: Class -> Generator ()
sayExportClass Class
cls = do
  [String] -> Generator ()
addExports ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$
    (Class -> String
toHsValueClassName' Class
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (..)") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    (Constness -> Class -> String
toHsPtrClassName' Constness
Const Class
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (..)") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    (Constness -> Class -> String
toHsPtrClassName' Constness
Nonconst Class
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (..)") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    Constness -> Class -> String
toHsDataTypeName' Constness
Const Class
cls String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    Constness -> Class -> String
toHsDataTypeName' Constness
Nonconst Class
cls String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    String
classUpCastConstReexportName String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    String
classUpCastReexportName String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    String
classDownCastConstReexportName String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    String
classDownCastReexportName String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    [[String]] -> [String]
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 [String
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 [String
classDecodeReexportName]
             else []
           , [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Ctor -> String) -> [Ctor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ctor -> String
getCtorReexportName ([Ctor] -> [String]) -> [Ctor] -> [String]
forall a b. (a -> b) -> a -> b
$ Class -> [Ctor]
classCtors Class
cls
           , [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Method -> String) -> [Method] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Method -> String
getMethodReexportName ([Method] -> [String]) -> [Method] -> [String]
forall a b. (a -> b) -> a -> b
$ Class -> [Method]
classMethods Class
cls
           ]

  Generator ()
ln
  String -> String -> Generator ()
sayBind String
classUpCastConstReexportName (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsCastMethodName' Constness
Const Class
cls
  String -> String -> Generator ()
sayBind String
classUpCastReexportName (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsCastMethodName' Constness
Nonconst Class
cls
  String -> String -> Generator ()
sayBind String
classDownCastConstReexportName (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsDownCastMethodName' Constness
Const Class
cls
  String -> String -> Generator ()
sayBind String
classDownCastReexportName (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
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 = String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
inFunction String
"sayExportSignal" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  let name :: String
name = Signal -> String
signalCName Signal
signal
      cls :: Class
cls = Signal -> Class
signalClass Signal
signal
      ptrClassName :: String
ptrClassName = Constness -> Class -> String
toHsPtrClassName' Constness
Nonconst Class
cls
      varName :: String
varName = Signal -> String
toSignalBindingName Signal
signal
  String -> Generator ()
addExport String
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 String)) Ctor
-> Maybe Ctor -> ReaderT Env (WriterT Output (Except String)) Ctor
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (String -> ReaderT Env (WriterT Output (Except String)) Ctor
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (WriterT Output (Except String)) Ctor)
-> String -> ReaderT Env (WriterT Output (Except String)) Ctor
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [String
"Couldn't find an appropriate ",
                String -> String
forall a. Show a => a -> String
show (ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
listenerClass),
                String
" constructor for signal ", String -> String
forall a. Show a => a -> String
show String
name]) (Maybe Ctor -> ReaderT Env (WriterT Output (Except String)) Ctor)
-> Maybe Ctor -> ReaderT Env (WriterT Output (Except String)) 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 -> String
fromExtName (Ctor -> ExtName
ctorExtName Ctor
ctor) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"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 String)) Method
-> Maybe Method
-> ReaderT Env (WriterT Output (Except String)) Method
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (String -> ReaderT Env (WriterT Output (Except String)) Method
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (WriterT Output (Except String)) Method)
-> String -> ReaderT Env (WriterT Output (Except String)) Method
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [String
"Couldn't find the isValid method in ",
                 Class -> String
forall a. Show a => a -> String
show Class
listenerClass, String
" for signal ", String -> String
forall a. Show a => a -> String
show String
name]) (Maybe Method
 -> ReaderT Env (WriterT Output (Except String)) Method)
-> Maybe Method
-> ReaderT Env (WriterT Output (Except String)) 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 String -> MethodImpl
RealMethod (String -> FnName String
forall name. name -> FnName name
FnName String
"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
$ String -> HsName
HsIdent String
ptrClassName, [HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"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
$ String -> HsName
HsIdent String
"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
$ String -> HsName
HsIdent String
"object")
                HsType
callbackHsType
      internalName :: String
internalName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                     [ ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
cls
                     , String
"::"
                     , String
name
                     , String
" ("
                     , ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
listenerClass
                     , String
")"
                     ]

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

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

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

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

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
. String -> HsImportSet
hsWholeModuleImport (String -> HsImportSet)
-> (Module -> String) -> Module -> HsImportSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Module -> String
getModuleName Interface
iface (Module -> Generator ())
-> ReaderT Env (WriterT Output (Except String)) Module
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExtName -> ReaderT Env (WriterT Output (Except String)) Module
getModuleForExtName ExtName
extName