{-# LANGUAGE
DeriveDataTypeable,
FlexibleContexts,
GeneralizedNewtypeDeriving
#-}
module Graphics.QML.Engine (
EngineConfig(
EngineConfig,
initialDocument,
contextObject,
importPaths,
pluginPaths),
defaultEngineConfig,
Engine,
runEngine,
runEngineWith,
runEngineAsync,
runEngineLoop,
joinEngine,
killEngine,
RunQML(),
runEventLoop,
runEventLoopNoArgs,
requireEventLoop,
setQtArgs,
getQtArgs,
QtFlag(
QtShareOpenGLContexts),
setQtFlag,
getQtFlag,
shutdownQt,
EventLoopException(),
DocumentPath(),
fileDocument,
uriDocument
) where
import Graphics.QML.Internal.JobQueue
import Graphics.QML.Internal.Marshal
import Graphics.QML.Internal.BindPrim
import Graphics.QML.Internal.BindCore
import Graphics.QML.Marshal ()
import Graphics.QML.Objects
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import qualified Data.Text as T
import Data.List
import Data.Traversable (sequenceA)
import Data.Typeable
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import System.Environment (getProgName, getArgs, withProgName, withArgs)
import System.FilePath (FilePath, isAbsolute, splitDirectories, pathSeparators)
data EngineConfig = EngineConfig {
initialDocument :: DocumentPath,
contextObject :: Maybe AnyObjRef,
importPaths :: [FilePath],
pluginPaths :: [FilePath]
}
defaultEngineConfig :: EngineConfig
defaultEngineConfig = EngineConfig {
initialDocument = DocumentPath "main.qml",
contextObject = Nothing,
importPaths = [],
pluginPaths = []
}
data Engine = Engine HsQMLEngineHandle (MVar ())
runEngineAsync :: EngineConfig -> RunQML Engine
runEngineAsync config = RunQML $ do
hsqmlInit
finishVar <- newEmptyMVar
let obj = contextObject config
DocumentPath res = initialDocument config
impPaths = importPaths config
plugPaths = pluginPaths config
stopCb = putMVar finishVar ()
ctxHndl <- sequenceA $ fmap mToHndl obj
engHndl <- mWithCVal (T.pack res) $ \resPtr ->
withManyArray0 mWithCVal (map T.pack impPaths) nullPtr $ \impPtr ->
withManyArray0 mWithCVal (map T.pack plugPaths) nullPtr $ \plugPtr ->
hsqmlCreateEngine ctxHndl (HsQMLStringHandle $ castPtr resPtr)
(castPtr impPtr) (castPtr plugPtr) stopCb
return $ Engine engHndl finishVar
withMany :: (a -> (b -> m c) -> m c) -> [a] -> ([b] -> m c) -> m c
withMany func as cont =
let rec (a:as') bs = func a (\b -> rec as' (bs . (b:)))
rec [] bs = cont $ bs []
in rec as id
withManyArray0 :: Storable b =>
(a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c
withManyArray0 func as term cont =
withMany func as $ \ptrs -> withArray0 term ptrs cont
joinEngine :: Engine -> IO ()
joinEngine (Engine _ finishVar) = void $ readMVar finishVar
killEngine :: Engine -> IO ()
killEngine (Engine hndl _) = postJob $ hsqmlKillEngine hndl
runEngineWith :: EngineConfig -> (Engine -> RunQML a) -> RunQML a
runEngineWith config with = do
eng <- runEngineAsync config
ret <- with eng
RunQML $ joinEngine eng
return ret
runEngine :: EngineConfig -> RunQML ()
runEngine config = runEngineAsync config >>= (RunQML . joinEngine)
runEngineLoop :: EngineConfig -> IO ()
runEngineLoop config =
runEventLoop $ runEngine config
newtype RunQML a = RunQML (IO a) deriving (Functor, Applicative, Monad)
instance MonadIO RunQML where
liftIO = RunQML
runEventLoop :: RunQML a -> IO a
runEventLoop (RunQML runFn) = do
prog <- getProgName
args <- getArgs
setQtArgs prog args
runEventLoopNoArgs . RunQML $ do
(prog', args') <- getQtArgsIO
withProgName prog' $ withArgs args' runFn
runEventLoopNoArgs :: RunQML a -> IO a
runEventLoopNoArgs (RunQML runFn) = tryRunInBoundThread $ do
hsqmlInit
finishVar <- newEmptyMVar
let startCb = void $ forkIO $ do
ret <- try runFn
case ret of
Left ex -> putMVar finishVar $ throwIO (ex :: SomeException)
Right ret' -> putMVar finishVar $ return ret'
hsqmlEvloopRelease
yieldCb = if rtsSupportsBoundThreads
then Nothing
else Just yield
status <- hsqmlEvloopRun startCb processJobs yieldCb
case statusException status of
Just ex -> throw ex
Nothing -> do
finFn <- takeMVar finishVar
finFn
tryRunInBoundThread :: IO a -> IO a
tryRunInBoundThread action =
if rtsSupportsBoundThreads
then runInBoundThread action
else action
requireEventLoop :: RunQML a -> IO a
requireEventLoop (RunQML runFn) = do
hsqmlInit
let reqFn = do
status <- hsqmlEvloopRequire
case statusException status of
Just ex -> throw ex
Nothing -> return ()
bracket_ reqFn hsqmlEvloopRelease runFn
setQtArgs :: String -> [String] -> IO Bool
setQtArgs prog args = do
hsqmlInit
withManyArray0 mWithCVal (map T.pack (prog:args)) nullPtr
(hsqmlSetArgs . castPtr)
getQtArgs :: RunQML (String, [String])
getQtArgs = RunQML getQtArgsIO
getQtArgsIO :: IO (String, [String])
getQtArgsIO = do
argc <- hsqmlGetArgsCount
withManyArray0 mWithCVal (replicate argc $ T.pack "") nullPtr $ \argv -> do
hsqmlGetArgs $ castPtr argv
argvs <- peekArray0 nullPtr argv
Just (arg0:args) <- runMaybeT $ mapM (fmap T.unpack . mFromCVal) argvs
return (arg0, args)
data QtFlag
= QtShareOpenGLContexts
deriving Show
internalFlag :: QtFlag -> HsQMLGlobalFlag
internalFlag QtShareOpenGLContexts = HsqmlGflagShareOpenglContexts
setQtFlag :: QtFlag -> Bool -> IO Bool
setQtFlag flag val = do
hsqmlInit
hsqmlSetFlag (internalFlag flag) val
getQtFlag :: QtFlag -> RunQML Bool
getQtFlag = RunQML . hsqmlGetFlag . internalFlag
shutdownQt :: IO ()
shutdownQt = do
status <- hsqmlEvloopShutdown
case statusException status of
Just ex -> throw ex
Nothing -> return ()
statusException :: HsQMLEventLoopStatus -> Maybe EventLoopException
statusException HsqmlEvloopOk = Nothing
statusException HsqmlEvloopAlreadyRunning = Just EventLoopAlreadyRunning
statusException HsqmlEvloopPostShutdown = Just EventLoopPostShutdown
statusException HsqmlEvloopWrongThread = Just EventLoopWrongThread
statusException HsqmlEvloopNotRunning = Just EventLoopNotRunning
statusException _ = Just EventLoopOtherError
data EventLoopException
= EventLoopAlreadyRunning
| EventLoopPostShutdown
| EventLoopWrongThread
| EventLoopNotRunning
| EventLoopOtherError
deriving (Show, Typeable)
instance Exception EventLoopException
newtype DocumentPath = DocumentPath String
fileDocument :: FilePath -> DocumentPath
fileDocument fp =
let ds = splitDirectories fp
isAbs = isAbsolute fp
fixHead =
(\cs -> if null cs then [] else '/':cs) .
takeWhile (`notElem` pathSeparators)
mapHead _ [] = []
mapHead f (x:xs) = f x : xs
afp = intercalate "/" $ mapHead fixHead ds
rfp = intercalate "/" ds
in DocumentPath $ if isAbs then "file://" ++ afp else rfp
uriDocument :: String -> DocumentPath
uriDocument = DocumentPath