-- This file is part of Qtah.
--
-- Copyright 2015-2017 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 .
{-# LANGUAGE CPP #-}
module Graphics.UI.Qtah.Generator.Module (
AModule (..),
aModuleHoppyModules,
QtModule,
makeQtModule,
makeQtModuleWithMinVersion,
qtModulePath,
qtModuleQtExports,
qtModuleHoppy,
) where
import Control.Monad (unless)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except (throwError)
#else
import Control.Monad.Error (throwError)
#endif
import Data.Char (toLower)
import Data.Foldable (forM_)
import Data.List (find, intersperse, sort)
import Data.Maybe (isJust, mapMaybe)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mconcat)
#endif
import Foreign.Hoppy.Generator.Language.Cpp (execChunkWriter, sayType)
import Foreign.Hoppy.Generator.Language.Haskell (
Generator,
HsTypeSide (HsHsSide),
addExport,
addExports,
addExtension,
addImports,
askInterface,
cppTypeToHsTypeAndUse,
getClassHaskellConversion,
getModuleForExtName,
getModuleName,
indent,
inFunction,
ln,
prettyPrint,
sayLn,
saysLn,
toHsBitspaceClassName',
toHsBitspaceToNumName',
toHsBitspaceTypeName',
toHsBitspaceValueName',
toHsCastMethodName',
toHsDataTypeName',
toHsDownCastMethodName',
toHsEnumTypeName',
toHsFnName',
toHsPtrClassName',
toHsValueClassName',
)
import Foreign.Hoppy.Generator.Spec (
Class,
Constness (Const, Nonconst),
Ctor,
Export (ExportBitspace, ExportCallback, ExportClass, ExportEnum, ExportFn, ExportVariable),
ExtName,
FnName (FnName),
Function,
Method,
MethodImpl (RealMethod),
Module,
Type (Internal_TCallback),
addAddendumHaskell,
bitspaceValueNames,
callbackParams,
classCtors,
classEntityForeignName,
classExtName,
classHaskellConversionFromCppFn,
classHaskellConversionToCppFn,
classMethods,
ctorExtName,
ctorParams,
fnExtName,
fromExtName,
getPrimaryExtName,
hsImport1,
hsImports,
hsWholeModuleImport,
makeModule,
methodExtName,
methodImpl,
moduleAddExports,
moduleAddHaskellName,
moduleModify',
varGetterExtName,
varIsConst,
varSetterExtName,
)
import Foreign.Hoppy.Generator.Types (objT)
import Graphics.UI.Qtah.Generator.Flags (Version, qrealFloat, qtVersion)
import Graphics.UI.Qtah.Generator.Common (fromMaybeM)
import Graphics.UI.Qtah.Generator.Types (
QtExport (QtExport,
QtExportEvent,
QtExportSceneEvent,
QtExportFnRenamed,
QtExportSignal,
QtExportSpecials
),
Signal,
qtExportToExport,
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 $ mapMaybe qtExportToExport 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 "" $ 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 mapMaybe qtExportToExport 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 (ExportVariable v) -> do
addExport $ toHsFnName' $ varGetterExtName v
unless (varIsConst v) $ addExport $ toHsFnName' $ varSetterExtName v
QtExport (ExportEnum e) -> do
let spec = toHsEnumTypeName' e ++ " (..)"
addExport spec
QtExport (ExportBitspace b) -> do
addExport $ toHsBitspaceTypeName' b
addExport $ toHsBitspaceToNumName' b
addExport $ toHsBitspaceClassName' b ++ " (..)"
forM_ (bitspaceValueNames b) $ \(_, valueName) ->
addExport $ toHsBitspaceValueName' b valueName
QtExport (ExportFn fn) -> do
addExport $ getFnReexportName fn
QtExportFnRenamed fn rename -> do
addExport rename
sayBind rename $ getFnImportName fn
QtExport (ExportCallback _) -> return ()
QtExport (ExportClass cls) -> sayExportClass cls
QtExportSignal sig -> sayExportSignal sig
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"]
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
addImports importForSignal
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 -> case ctorParams ctor of
[Internal_TCallback {}] -> True
_ -> False
let [callbackType@(Internal_TCallback callback)] = ctorParams listenerCtor
paramTypes = callbackParams callback
-- Also find the 'connectListener' method.
listenerConnectMethod <-
fromMaybeM (throwError $ concat
["Couldn't find the connectListener method in ",
show listenerClass, " for signal ", show name]) $
find ((RealMethod (FnName "connectListener") ==) . methodImpl) $ classMethods listenerClass
callbackHsType <- cppTypeToHsTypeAndUse HsHsSide callbackType
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
, ")"
]
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, " fn'"]
saysLn [toHsFnName' $ classEntityForeignName listenerClass listenerConnectMethod,
" listener' object' ", show (toSignalConnectName signal paramTypes)]
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 (execChunkWriter . sayType Nothing) paramTypes) ++
[")"]
importWholeModuleForExtName :: ExtName -> Generator ()
importWholeModuleForExtName extName = do
iface <- askInterface
addImports . hsWholeModuleImport . getModuleName iface =<< getModuleForExtName extName