qtah-generator-0.7.0: src/Graphics/UI/Qtah/Generator/Module.hs
-- This file is part of Qtah.
--
-- Copyright 2015-2020 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 (AHoppyModule m) = [m]
aModuleHoppyModules (AQtModule qm) = [qtModuleHoppy qm, qtModuleHoppyWrapper 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
{ qtModulePath :: [String]
, qtModuleQtExports :: [QtExport]
-- ^ A list of exports whose generated Hoppy bindings will be re-exported in
-- this module.
, qtModuleHoppy :: Module
, qtModuleHoppyWrapper :: Module
}
makeQtModule :: [String] -> [QtExport] -> QtModule
makeQtModule [] _ = error "makeQtModule: Module path must be nonempty."
makeQtModule modulePath@(_:moduleNameParts) qtExports =
let lowerName = map toLower $ concat moduleNameParts
in QtModule
{ qtModulePath = modulePath
, qtModuleQtExports = qtExports
, qtModuleHoppy =
moduleModify' (makeModule lowerName
(concat ["b_", lowerName, ".hpp"])
(concat ["b_", lowerName, ".cpp"])) $ do
moduleAddHaskellName $ "Generated" : modulePath
moduleAddExports $ concatMap qtExportToExports qtExports
, qtModuleHoppyWrapper =
addAddendumHaskell (sayWrapperModule modulePath qtExports) $
moduleModify' (makeModule (lowerName ++ "wrap")
(concat ["b_", lowerName, "_w.hpp"])
(concat ["b_", lowerName, "_w.cpp"])) $
moduleAddHaskellName 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 modulePath minVersion qtExports =
makeQtModule modulePath $
if qtVersion >= minVersion then qtExports else []
sayWrapperModule :: [String] -> [QtExport] -> Generator ()
sayWrapperModule modulePath qtExports = inFunction "<Qtah generateModule>" $ do
addExtension "NoMonomorphismRestriction"
-- As in generated Hoppy bindings, avoid non-qualified Prelude uses in
-- generated code here.
addImports $ hsImports "Prelude" []
-- Import the underlying Hoppy module wholesale.
case concatMap qtExportToExports qtExports of
[] -> return ()
export:_ -> importWholeModuleForExtName $ getPrimaryExtName export
-- Generate bindings for all of the exports.
mapM_ (sayQtExport modulePath) qtExports
getFnImportName :: Function -> String
getFnImportName = toHsFnName' . fnExtName
getFnReexportName :: Function -> String
getFnReexportName = getFnImportName
classUpCastReexportName :: String
classUpCastReexportName = "cast"
classUpCastConstReexportName :: String
classUpCastConstReexportName = "castConst"
classDownCastReexportName :: String
classDownCastReexportName = "downCast"
classDownCastConstReexportName :: String
classDownCastConstReexportName = "downCastConst"
classEncodeReexportName :: String
classEncodeReexportName = "encode"
classDecodeReexportName :: String
classDecodeReexportName = "decode"
getCtorReexportName :: Ctor -> String
getCtorReexportName = toHsFnName' . ctorExtName
getMethodReexportName :: Method -> String
getMethodReexportName = toHsFnName' . methodExtName
sayClassEncodingFnReexports :: Class -> Generator ()
sayClassEncodingFnReexports cls = inFunction "sayClassEncodingFnReexports" $ do
let conv = getClassHaskellConversion cls
forM_ (classHaskellConversionToCppFn conv) $ \_ -> do
hsHsType <- cppTypeToHsTypeAndUse HsHsSide (objT cls)
let dataTypeName = toHsDataTypeName' Nonconst cls
ptrHsType = HsTyCon $ UnQual $ HsIdent dataTypeName
encodeFnType = HsTyFun hsHsType $ HsTyApp (HsTyCon $ UnQual $ HsIdent "QtahP.IO") ptrHsType
addImports $ mconcat [importForPrelude, importForRuntime]
ln
saysLn [classEncodeReexportName, " :: ", prettyPrint encodeFnType]
saysLn [classEncodeReexportName, " = QtahFHR.encodeAs (QtahP.undefined :: ", dataTypeName, ")"]
forM_ (classHaskellConversionFromCppFn conv) $ \_ -> do
hsHsType <- cppTypeToHsTypeAndUse HsHsSide (objT cls)
let constPtrClassName = toHsPtrClassName' Const cls
thisTyVar = HsTyVar $ HsIdent "this"
decodeFnType = HsQualType [(UnQual $ HsIdent constPtrClassName, [thisTyVar])] $
HsTyFun thisTyVar $
HsTyApp (HsTyCon $ UnQual $ HsIdent "QtahP.IO") hsHsType
addImports $ mconcat [importForPrelude, importForRuntime]
ln
saysLn [classDecodeReexportName, " :: ", prettyPrint decodeFnType]
saysLn [classDecodeReexportName, " = QtahFHR.decode QtahP.. ", toHsCastMethodName' Const cls]
handleEventKind :: [String] -> String -> Class -> Generator ()
handleEventKind path eventKind cls = do
let typeName = toHsDataTypeName' Nonconst cls
addImports $ hsImport1 "Prelude" "($)"
ln
saysLn ["instance Qtah", eventKind, ".", eventKind, " ", typeName, " where"]
indent $ do
saysLn ["on", eventKind, " receiver' handler' = Qtah", eventKind,
".onAny", eventKind, " receiver' $ \\_ qevent' ->"]
indent $
if path == ["Core", "QEvent"]
then sayLn "handler' qevent'"
else do
addImports $ mconcat [hsImport1 "Prelude" "(==)",
importForPrelude,
importForRuntime]
saysLn ["let event' = ", classDownCastReexportName, " qevent'"]
sayLn "in if event' == QtahFHR.nullptr then QtahP.return QtahP.False else handler' event'"
sayQtExport :: [String] -> QtExport -> Generator ()
sayQtExport path qtExport = case qtExport of
QtExport export -> doExport export
QtExportFnRenamed fn rename -> do
addExport rename
sayBind rename $ getFnImportName fn
QtExportClassAndSignals cls sigs -> do
sayExportClass cls
mapM_ sayExportSignal sigs
QtExportEvent cls -> do
sayExportClass cls
addImports $ mconcat [importForEvent, importForSceneEvent]
handleEventKind path "Event" cls
handleEventKind path "SceneEvent" cls
QtExportSceneEvent cls -> do
sayExportClass cls
addImports importForSceneEvent
handleEventKind path "SceneEvent" cls
QtExportSpecials -> do
-- Generate a type synonym for qreal.
addImports importForPrelude
addExport "QReal"
ln
saysLn ["type QReal = ", if qrealFloat then "QtahP.Float" else "QtahP.Double"]
where doExport export = case castExport export of
Just c -> doExportClass c
Nothing -> case castExport export of
Just e -> doExportEnum e
Nothing -> case castExport export of
Just flags -> doExportFlags flags
Nothing -> case castExport export of
Just f -> doExportFunction f
Nothing -> case castExport export of
Just v -> doExportVariable v
Nothing -> return ()
doExportClass cls = sayExportClass cls
doExportEnum e = do
let spec = toHsEnumTypeName' e ++ " (..)"
addExport spec
doExportFlags flags = do
let enum = flagsEnum flags
typeName = toHsFlagsTypeName' flags
typeclassName = toHsFlagsTypeclassName' flags
-- Re-export the data type and typeclass.
addExport typeName
addExport' typeclassName
-- Re-export the entries' bindings.
forM_ (enumValueMapNames $ enumValues enum) $ \words -> do
let words' = enumGetOverriddenEntryName Haskell enum words
addExport $ toHsFlagsBindingName' flags words'
doExportFunction f = addExport $ getFnReexportName f
doExportVariable v = do
addExport $ toHsFnName' $ varGetterExtName v
unless (varIsConst v) $ addExport $ toHsFnName' $ varSetterExtName v
sayExportClass :: Class -> Generator ()
sayExportClass cls = do
addExports $
(toHsValueClassName' cls ++ " (..)") :
(toHsPtrClassName' Const cls ++ " (..)") :
(toHsPtrClassName' Nonconst cls ++ " (..)") :
toHsDataTypeName' Const cls :
toHsDataTypeName' Nonconst cls :
classUpCastConstReexportName :
classUpCastReexportName :
classDownCastConstReexportName :
classDownCastReexportName :
concat [ if isJust $ classHaskellConversionToCppFn $ getClassHaskellConversion cls
then [classEncodeReexportName]
else []
, if isJust $ classHaskellConversionFromCppFn $ getClassHaskellConversion cls
then [classDecodeReexportName]
else []
, sort $ map getCtorReexportName $ classCtors cls
, sort $ map getMethodReexportName $ classMethods cls
]
ln
sayBind classUpCastConstReexportName $ toHsCastMethodName' Const cls
sayBind classUpCastReexportName $ toHsCastMethodName' Nonconst cls
sayBind classDownCastConstReexportName $ toHsDownCastMethodName' Const cls
sayBind classDownCastReexportName $ toHsDownCastMethodName' Nonconst cls
sayClassEncodingFnReexports 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 = inFunction "sayExportSignal" $ do
let name = signalCName signal
cls = signalClass signal
ptrClassName = toHsPtrClassName' Nonconst cls
varName = toSignalBindingName signal
addExport varName
let listenerClass = signalListenerClass signal
importWholeModuleForExtName $ classExtName listenerClass
-- Find the listener constructor that only takes a callback.
listenerCtor <-
fromMaybeM (throwError $ concat
["Couldn't find an appropriate ",
show (fromExtName $ classExtName listenerClass),
" constructor for signal ", show name]) $
flip find (classCtors listenerClass) $ \ctor -> fromExtName (ctorExtName ctor) == "new"
let callback = signalCallback signal
paramTypes = map parameterType $ callbackParams callback
-- Also find the 'isValid' method.
isValidMethod <-
fromMaybeM (throwError $ concat
["Couldn't find the isValid method in ",
show listenerClass, " for signal ", show name]) $
find ((RealMethod (FnName "isValid") ==) . methodImpl) $ classMethods listenerClass
callbackHsType <- cppTypeToHsTypeAndUse HsHsSide $ callbackT callback
let varType = HsQualType [(UnQual $ HsIdent ptrClassName, [HsTyVar $ HsIdent "object"])] $
HsTyApp (HsTyApp (HsTyCon $ UnQual $ HsIdent "QtahSignal.Signal") $
HsTyVar $ HsIdent "object")
callbackHsType
internalName = concat
[ fromExtName $ classExtName cls
, "::"
, name
, " ("
, fromExtName $ classExtName listenerClass
, ")"
]
addImports $ mconcat [hsImports "Prelude" ["($)", "(>>)"],
importForPrelude,
importForRuntime,
importForSignal]
ln
saysLn [varName, " :: ", prettyPrint varType]
saysLn [varName, " = QtahSignal.Signal"]
indent $ do
sayLn "{ QtahSignal.internalConnectSignal = \\object' fn' -> do"
indent $ do
saysLn ["listener' <- ",
toHsFnName' $ classEntityForeignName listenerClass listenerCtor,
" object' ",
show (toSignalConnectName signal paramTypes),
" fn'"]
saysLn ["valid' <- ",
toHsFnName' $ classEntityForeignName listenerClass isValidMethod,
" listener'"]
sayLn "if valid'"
indent $ do
sayLn "then QtahP.fmap QtahP.Just $ QtahSignal.internalMakeConnection listener'"
sayLn "else QtahFHR.delete listener' >> QtahP.return QtahP.Nothing"
saysLn [", QtahSignal.internalName = ", show internalName]
sayLn "}"
sayBind :: String -> String -> Generator ()
sayBind name value = saysLn [name, " = ", value]
toSignalBindingName :: Signal -> String
toSignalBindingName = (++ "Signal") . signalHaskellName
toSignalConnectName :: Signal -> [Type] -> String
toSignalConnectName signal paramTypes =
concat $
"2" : -- This is a magic code added by the SIGNAL() macro.
signalCName signal :
"(" :
intersperse "," (map (chunkContents . execChunkWriter . sayType Nothing) paramTypes) ++
[")"]
importWholeModuleForExtName :: ExtName -> Generator ()
importWholeModuleForExtName extName = do
iface <- askInterface
addImports . hsWholeModuleImport . getModuleName iface =<< getModuleForExtName extName