module Graphics.QML.Engine (
EngineConfig(
EngineConfig,
initialDocument,
contextObject,
importPaths,
pluginPaths),
defaultEngineConfig,
Engine,
runEngine,
runEngineWith,
runEngineAsync,
runEngineLoop,
RunQML(),
runEventLoop,
requireEventLoop,
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 qualified Data.Text as T
import Data.List
import Data.Traversable
import Data.Typeable
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
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
runEngineImpl :: EngineConfig -> IO () -> IO Engine
runEngineImpl config stopCb = do
hsqmlInit
let obj = contextObject config
DocumentPath res = initialDocument config
impPaths = importPaths config
plugPaths = pluginPaths config
hndl <- sequenceA $ fmap mToHndl obj
mWithCVal (T.pack res) $ \resPtr ->
withManyArray0 mWithCVal (map T.pack impPaths) nullPtr $ \impPtr ->
withManyArray0 mWithCVal (map T.pack plugPaths) nullPtr $ \plugPtr ->
hsqmlCreateEngine hndl (HsQMLStringHandle $ castPtr resPtr)
(castPtr impPtr) (castPtr plugPtr) stopCb
return Engine
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
runEngine :: EngineConfig -> RunQML ()
runEngine config = runEngineWith config (const $ return ())
runEngineWith :: EngineConfig -> (Engine -> RunQML a) -> RunQML a
runEngineWith config with = RunQML $ do
finishVar <- newEmptyMVar
let stopCb = putMVar finishVar ()
eng <- runEngineImpl config stopCb
let (RunQML withIO) = with eng
ret <- withIO
void $ takeMVar finishVar
return ret
runEngineAsync :: EngineConfig -> RunQML Engine
runEngineAsync config = RunQML $ runEngineImpl config (return ())
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) = 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
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