{-# LANGUAGE
    DeriveDataTypeable,
    FlexibleContexts,
    GeneralizedNewtypeDeriving
  #-}

-- | Functions for starting QML engines, displaying content in a window.
module Graphics.QML.Engine (
  -- * Engines
  EngineConfig(
    EngineConfig,
    initialDocument,
    contextObject,
    importPaths,
    pluginPaths,
    iconPath),
  defaultEngineConfig,
  Engine,
  runEngine,
  runEngineWith,
  runEngineAsync,
  runEngineLoop,
  joinEngine,
  killEngine,
  enableHighDpiScaling,

  -- * Event Loop
  RunQML(),
  runEventLoop,
  runEventLoopNoArgs,
  requireEventLoop,
  setQtArgs,
  getQtArgs,
  QtFlag(
    QtShareOpenGLContexts,
    QtEnableQMLDebug),
  setQtFlag,
  getQtFlag,
  shutdownQt,
  EventLoopException(),

  -- * Document Paths
  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.C.String (CString, withCString)
import Foreign.C.Types (CChar)
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import System.Environment (getProgName, getArgs, withProgName, withArgs)
import System.FilePath (FilePath, isAbsolute, splitDirectories, pathSeparators)

-- | Holds parameters for configuring a QML runtime engine.
data EngineConfig = EngineConfig {
  -- | Path to the first QML document to be loaded.
  EngineConfig -> DocumentPath
initialDocument    :: DocumentPath,
  -- | Context 'Object' made available to QML script code.
  EngineConfig -> Maybe AnyObjRef
contextObject      :: Maybe AnyObjRef,
  -- | Additional search paths for QML modules
  EngineConfig -> [FilePath]
importPaths        :: [FilePath],
  -- | Additional search paths for QML native plugins
  EngineConfig -> [FilePath]
pluginPaths        :: [FilePath],
  EngineConfig -> Maybe FilePath
iconPath           :: Maybe FilePath
}

foreign import ccall "hsqml_set_window_icon" setWindowIcon :: Ptr CChar -> IO ()

foreign import ccall "hsqml_enable_high_dpi_scaling" enableHighDpiScaling :: IO ()


-- | Default engine configuration. Loads @\"main.qml\"@ from the current
-- working directory into a visible window with no context object.
defaultEngineConfig :: EngineConfig
defaultEngineConfig :: EngineConfig
defaultEngineConfig = EngineConfig {
  initialDocument :: DocumentPath
initialDocument    = FilePath -> DocumentPath
DocumentPath FilePath
"main.qml",
  contextObject :: Maybe AnyObjRef
contextObject      = Maybe AnyObjRef
forall a. Maybe a
Nothing,
  importPaths :: [FilePath]
importPaths        = [],
  pluginPaths :: [FilePath]
pluginPaths        = [],
  iconPath :: Maybe FilePath
iconPath           = Maybe FilePath
forall a. Maybe a
Nothing
}

-- | Represents a QML engine.
data Engine = Engine HsQMLEngineHandle (MVar ())

-- | Starts a new QML engine using the supplied configuration and returns
-- immediately without blocking.
runEngineAsync :: EngineConfig -> RunQML Engine
runEngineAsync :: EngineConfig -> RunQML Engine
runEngineAsync EngineConfig
config = IO Engine -> RunQML Engine
forall a. IO a -> RunQML a
RunQML (IO Engine -> RunQML Engine) -> IO Engine -> RunQML Engine
forall a b. (a -> b) -> a -> b
$ do
    IO ()
hsqmlInit
    MVar ()
finishVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

    let obj :: Maybe AnyObjRef
obj = EngineConfig -> Maybe AnyObjRef
contextObject EngineConfig
config
        DocumentPath FilePath
res = EngineConfig -> DocumentPath
initialDocument EngineConfig
config
        impPaths :: [FilePath]
impPaths = EngineConfig -> [FilePath]
importPaths EngineConfig
config
        plugPaths :: [FilePath]
plugPaths = EngineConfig -> [FilePath]
pluginPaths EngineConfig
config
        stopCb :: IO ()
stopCb = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
finishVar () 

    Maybe HsQMLObjectHandle
ctxHndl <- Maybe (IO HsQMLObjectHandle) -> IO (Maybe HsQMLObjectHandle)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe a)
sequenceA (Maybe (IO HsQMLObjectHandle) -> IO (Maybe HsQMLObjectHandle))
-> Maybe (IO HsQMLObjectHandle) -> IO (Maybe HsQMLObjectHandle)
forall a b. (a -> b) -> a -> b
$ (AnyObjRef -> IO HsQMLObjectHandle)
-> Maybe AnyObjRef -> Maybe (IO HsQMLObjectHandle)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnyObjRef -> IO HsQMLObjectHandle
forall t. Marshal t => MToHndlFunc t
mToHndl Maybe AnyObjRef
obj
    HsQMLEngineHandle
engHndl <- Text -> (Ptr () -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle
MWithCValFunc Text
forall t. Marshal t => MWithCValFunc t
mWithCVal (FilePath -> Text
T.pack FilePath
res) ((Ptr () -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle)
-> (Ptr () -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle
forall a b. (a -> b) -> a -> b
$ \Ptr ()
resPtr ->
        (Text -> (Ptr () -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle)
-> [Text]
-> Ptr ()
-> (Ptr (Ptr ()) -> IO HsQMLEngineHandle)
-> IO HsQMLEngineHandle
forall b a c.
Storable b =>
(a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c
withManyArray0 Text -> (Ptr () -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle
MWithCValFunc Text
forall t. Marshal t => MWithCValFunc t
mWithCVal ((FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
T.pack [FilePath]
impPaths) Ptr ()
forall a. Ptr a
nullPtr ((Ptr (Ptr ()) -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle)
-> (Ptr (Ptr ()) -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
impPtr ->
        (Text -> (Ptr () -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle)
-> [Text]
-> Ptr ()
-> (Ptr (Ptr ()) -> IO HsQMLEngineHandle)
-> IO HsQMLEngineHandle
forall b a c.
Storable b =>
(a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c
withManyArray0 Text -> (Ptr () -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle
MWithCValFunc Text
forall t. Marshal t => MWithCValFunc t
mWithCVal ((FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
T.pack [FilePath]
plugPaths) Ptr ()
forall a. Ptr a
nullPtr ((Ptr (Ptr ()) -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle)
-> (Ptr (Ptr ()) -> IO HsQMLEngineHandle) -> IO HsQMLEngineHandle
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
plugPtr ->
            Maybe HsQMLObjectHandle
-> HsQMLStringHandle
-> Ptr HsQMLStringHandle
-> Ptr HsQMLStringHandle
-> IO ()
-> IO HsQMLEngineHandle
hsqmlCreateEngine Maybe HsQMLObjectHandle
ctxHndl (Ptr HsQMLStringHandle -> HsQMLStringHandle
HsQMLStringHandle (Ptr HsQMLStringHandle -> HsQMLStringHandle)
-> Ptr HsQMLStringHandle -> HsQMLStringHandle
forall a b. (a -> b) -> a -> b
$ Ptr () -> Ptr HsQMLStringHandle
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
resPtr)
                (Ptr (Ptr ()) -> Ptr HsQMLStringHandle
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr ())
impPtr) (Ptr (Ptr ()) -> Ptr HsQMLStringHandle
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr ())
plugPtr) IO ()
stopCb

    case EngineConfig -> Maybe FilePath
iconPath EngineConfig
config of
        Just FilePath
path -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (CString -> IO ()) -> IO ()
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
path CString -> IO ()
setWindowIcon
        Maybe FilePath
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Engine -> IO Engine
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Engine -> IO Engine) -> Engine -> IO Engine
forall a b. (a -> b) -> a -> b
$ HsQMLEngineHandle -> MVar () -> Engine
Engine HsQMLEngineHandle
engHndl MVar ()
finishVar

withMany :: (a -> (b -> m c) -> m c) -> [a] -> ([b] -> m c) -> m c
withMany :: forall a b (m :: * -> *) c.
(a -> (b -> m c) -> m c) -> [a] -> ([b] -> m c) -> m c
withMany a -> (b -> m c) -> m c
func [a]
as [b] -> m c
cont =
    let rec :: [a] -> ([b] -> [b]) -> m c
rec (a
a:[a]
as') [b] -> [b]
bs = a -> (b -> m c) -> m c
func a
a (\b
b -> [a] -> ([b] -> [b]) -> m c
rec [a]
as' ([b] -> [b]
bs ([b] -> [b]) -> ([b] -> [b]) -> [b] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b
b:)))
        rec []      [b] -> [b]
bs = [b] -> m c
cont ([b] -> m c) -> [b] -> m c
forall a b. (a -> b) -> a -> b
$ [b] -> [b]
bs []
    in [a] -> ([b] -> [b]) -> m c
rec [a]
as [b] -> [b]
forall a. a -> a
id

withManyArray0 :: Storable b =>
    (a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c
withManyArray0 :: forall b a c.
Storable b =>
(a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c
withManyArray0 a -> (b -> IO c) -> IO c
func [a]
as b
term Ptr b -> IO c
cont =
    (a -> (b -> IO c) -> IO c) -> [a] -> ([b] -> IO c) -> IO c
forall a b (m :: * -> *) c.
(a -> (b -> m c) -> m c) -> [a] -> ([b] -> m c) -> m c
withMany a -> (b -> IO c) -> IO c
func [a]
as (([b] -> IO c) -> IO c) -> ([b] -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \[b]
ptrs -> b -> [b] -> (Ptr b -> IO c) -> IO c
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 b
term [b]
ptrs Ptr b -> IO c
cont

-- | Waits for the specified Engine to terminate.
joinEngine :: Engine -> IO ()
joinEngine :: Engine -> IO ()
joinEngine (Engine HsQMLEngineHandle
_ MVar ()
finishVar) = IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
finishVar

-- | Kills the specified Engine asynchronously.
killEngine :: Engine -> IO ()
killEngine :: Engine -> IO ()
killEngine (Engine HsQMLEngineHandle
hndl MVar ()
_) = IO () -> IO ()
postJob (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HsQMLEngineHandle -> IO ()
hsqmlKillEngine HsQMLEngineHandle
hndl

-- | Starts a new QML engine using the supplied configuration. The \'with\'
-- function is executed once the engine has been started and after it returns
-- this function blocks until the engine has terminated.
runEngineWith :: EngineConfig -> (Engine -> RunQML a) -> RunQML a
runEngineWith :: forall a. EngineConfig -> (Engine -> RunQML a) -> RunQML a
runEngineWith EngineConfig
config Engine -> RunQML a
with = do
    Engine
eng <- EngineConfig -> RunQML Engine
runEngineAsync EngineConfig
config
    a
ret <- Engine -> RunQML a
with Engine
eng
    IO () -> RunQML ()
forall a. IO a -> RunQML a
RunQML (IO () -> RunQML ()) -> IO () -> RunQML ()
forall a b. (a -> b) -> a -> b
$ Engine -> IO ()
joinEngine Engine
eng
    a -> RunQML a
forall a. a -> RunQML a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret

-- | Starts a new QML engine using the supplied configuration and blocks until
-- the engine has terminated.
runEngine :: EngineConfig -> RunQML ()
runEngine :: EngineConfig -> RunQML ()
runEngine EngineConfig
config = EngineConfig -> RunQML Engine
runEngineAsync EngineConfig
config RunQML Engine -> (Engine -> RunQML ()) -> RunQML ()
forall a b. RunQML a -> (a -> RunQML b) -> RunQML b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IO () -> RunQML ()
forall a. IO a -> RunQML a
RunQML (IO () -> RunQML ()) -> (Engine -> IO ()) -> Engine -> RunQML ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Engine -> IO ()
joinEngine)

-- | Conveniance function that both runs the event loop and starts a new QML
-- engine. It blocks keeping the event loop running until the engine has
-- terminated.
runEngineLoop :: EngineConfig -> IO ()
runEngineLoop :: EngineConfig -> IO ()
runEngineLoop EngineConfig
config =
    RunQML () -> IO ()
forall a. RunQML a -> IO a
runEventLoop (RunQML () -> IO ()) -> RunQML () -> IO ()
forall a b. (a -> b) -> a -> b
$ EngineConfig -> RunQML ()
runEngine EngineConfig
config

-- | Wrapper around the IO monad for running actions which depend on the Qt
-- event loop.
newtype RunQML a = RunQML (IO a) deriving ((forall a b. (a -> b) -> RunQML a -> RunQML b)
-> (forall a b. a -> RunQML b -> RunQML a) -> Functor RunQML
forall a b. a -> RunQML b -> RunQML a
forall a b. (a -> b) -> RunQML a -> RunQML b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> RunQML a -> RunQML b
fmap :: forall a b. (a -> b) -> RunQML a -> RunQML b
$c<$ :: forall a b. a -> RunQML b -> RunQML a
<$ :: forall a b. a -> RunQML b -> RunQML a
Functor, Functor RunQML
Functor RunQML =>
(forall a. a -> RunQML a)
-> (forall a b. RunQML (a -> b) -> RunQML a -> RunQML b)
-> (forall a b c.
    (a -> b -> c) -> RunQML a -> RunQML b -> RunQML c)
-> (forall a b. RunQML a -> RunQML b -> RunQML b)
-> (forall a b. RunQML a -> RunQML b -> RunQML a)
-> Applicative RunQML
forall a. a -> RunQML a
forall a b. RunQML a -> RunQML b -> RunQML a
forall a b. RunQML a -> RunQML b -> RunQML b
forall a b. RunQML (a -> b) -> RunQML a -> RunQML b
forall a b c. (a -> b -> c) -> RunQML a -> RunQML b -> RunQML c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> RunQML a
pure :: forall a. a -> RunQML a
$c<*> :: forall a b. RunQML (a -> b) -> RunQML a -> RunQML b
<*> :: forall a b. RunQML (a -> b) -> RunQML a -> RunQML b
$cliftA2 :: forall a b c. (a -> b -> c) -> RunQML a -> RunQML b -> RunQML c
liftA2 :: forall a b c. (a -> b -> c) -> RunQML a -> RunQML b -> RunQML c
$c*> :: forall a b. RunQML a -> RunQML b -> RunQML b
*> :: forall a b. RunQML a -> RunQML b -> RunQML b
$c<* :: forall a b. RunQML a -> RunQML b -> RunQML a
<* :: forall a b. RunQML a -> RunQML b -> RunQML a
Applicative, Applicative RunQML
Applicative RunQML =>
(forall a b. RunQML a -> (a -> RunQML b) -> RunQML b)
-> (forall a b. RunQML a -> RunQML b -> RunQML b)
-> (forall a. a -> RunQML a)
-> Monad RunQML
forall a. a -> RunQML a
forall a b. RunQML a -> RunQML b -> RunQML b
forall a b. RunQML a -> (a -> RunQML b) -> RunQML b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. RunQML a -> (a -> RunQML b) -> RunQML b
>>= :: forall a b. RunQML a -> (a -> RunQML b) -> RunQML b
$c>> :: forall a b. RunQML a -> RunQML b -> RunQML b
>> :: forall a b. RunQML a -> RunQML b -> RunQML b
$creturn :: forall a. a -> RunQML a
return :: forall a. a -> RunQML a
Monad)

instance MonadIO RunQML where
    liftIO :: forall a. IO a -> RunQML a
liftIO = IO a -> RunQML a
forall a. IO a -> RunQML a
RunQML

-- | This function enters the Qt event loop and executes the supplied function
-- in the 'RunQML' monad on a new unbound thread. The event loop will continue
-- to run until all functions in the 'RunQML' monad have completed. This
-- includes both the 'RunQML' function launched by this call and any launched
-- asynchronously via 'requireEventLoop'. When the event loop exits, all
-- engines will be terminated.
--
-- It's recommended that applications run the event loop on their primordial
-- thread as some platforms mandate this. Once the event loop has finished, it
-- can be started again, but only on the same operating system thread as
-- before. If the event loop fails to start then an 'EventLoopException' will
-- be thrown.
--
-- If the event loop is entered for the first time then the currently set
-- runtime command line arguments will be passed to Qt. Hence, while calling
-- back to the supplied function, attempts to read the runtime command line
-- arguments using the System.Environment module will only return those
-- arguments not already consumed by Qt (per 'getQtArgs').
runEventLoop :: RunQML a -> IO a
runEventLoop :: forall a. RunQML a -> IO a
runEventLoop (RunQML IO a
runFn) = do
    FilePath
prog <- IO FilePath
getProgName
    [FilePath]
args <- IO [FilePath]
getArgs
    FilePath -> [FilePath] -> IO Bool
setQtArgs FilePath
prog [FilePath]
args
    RunQML a -> IO a
forall a. RunQML a -> IO a
runEventLoopNoArgs (RunQML a -> IO a) -> (IO a -> RunQML a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> RunQML a
forall a. IO a -> RunQML a
RunQML (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
        (FilePath
prog', [FilePath]
args') <- IO (FilePath, [FilePath])
getQtArgsIO
        FilePath -> IO a -> IO a
forall a. FilePath -> IO a -> IO a
withProgName FilePath
prog' (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ [FilePath] -> IO a -> IO a
forall a. [FilePath] -> IO a -> IO a
withArgs [FilePath]
args' IO a
runFn

-- | Enters the Qt event loop in the same manner as 'runEventLoop', but does
-- not perform any processing related to command line arguments.
runEventLoopNoArgs :: RunQML a -> IO a
runEventLoopNoArgs :: forall a. RunQML a -> IO a
runEventLoopNoArgs (RunQML IO a
runFn) = IO a -> IO a
forall a. IO a -> IO a
tryRunInBoundThread (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    IO ()
hsqmlInit
    MVar (IO a)
finishVar <- IO (MVar (IO a))
forall a. IO (MVar a)
newEmptyMVar
    let startCb :: IO ()
startCb = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
            Either SomeException a
ret <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
runFn
            case Either SomeException a
ret of
                Left SomeException
ex -> MVar (IO a) -> IO a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO a)
finishVar (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeException
ex :: SomeException)
                Right a
ret' -> MVar (IO a) -> IO a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO a)
finishVar (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret'
            IO ()
hsqmlEvloopRelease
        yieldCb :: Maybe (IO ())
yieldCb = if Bool
rtsSupportsBoundThreads
                  then Maybe (IO ())
forall a. Maybe a
Nothing
                  else IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just IO ()
yield
    HsQMLEventLoopStatus
status <- IO () -> IO () -> Maybe (IO ()) -> IO HsQMLEventLoopStatus
hsqmlEvloopRun IO ()
startCb IO ()
processJobs Maybe (IO ())
yieldCb
    case HsQMLEventLoopStatus -> Maybe EventLoopException
statusException HsQMLEventLoopStatus
status of
        Just EventLoopException
ex -> EventLoopException -> IO a
forall a e. Exception e => e -> a
throw EventLoopException
ex
        Maybe EventLoopException
Nothing -> do 
            IO a
finFn <- MVar (IO a) -> IO (IO a)
forall a. MVar a -> IO a
takeMVar MVar (IO a)
finishVar
            IO a
finFn

tryRunInBoundThread :: IO a -> IO a
tryRunInBoundThread :: forall a. IO a -> IO a
tryRunInBoundThread IO a
action =
    if Bool
rtsSupportsBoundThreads
    then IO a -> IO a
forall a. IO a -> IO a
runInBoundThread IO a
action
    else IO a
action

-- | Executes a function in the 'RunQML' monad asynchronously to the event
-- loop. Callers must apply their own sychronisation to ensure that the event
-- loop is currently running when this function is called, otherwise an
-- 'EventLoopException' will be thrown. The event loop will not exit until the
-- supplied function has completed.
requireEventLoop :: RunQML a -> IO a
requireEventLoop :: forall a. RunQML a -> IO a
requireEventLoop (RunQML IO a
runFn) = do
    IO ()
hsqmlInit
    let reqFn :: IO ()
reqFn = do
            HsQMLEventLoopStatus
status <- IO HsQMLEventLoopStatus
hsqmlEvloopRequire
            case HsQMLEventLoopStatus -> Maybe EventLoopException
statusException HsQMLEventLoopStatus
status of
                Just EventLoopException
ex -> EventLoopException -> IO ()
forall a e. Exception e => e -> a
throw EventLoopException
ex
                Maybe EventLoopException
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
reqFn IO ()
hsqmlEvloopRelease IO a
runFn

-- | Sets the program name and command line arguments used by Qt and returns
-- True if successful. This must be called before the first time the Qt event
-- loop is entered otherwise it will have no effect and return False. By
-- default Qt receives no arguments and the program name is set to "HsQML".
setQtArgs :: String -> [String] -> IO Bool
setQtArgs :: FilePath -> [FilePath] -> IO Bool
setQtArgs FilePath
prog [FilePath]
args = do
    IO ()
hsqmlInit
    (Text -> (Ptr () -> IO Bool) -> IO Bool)
-> [Text] -> Ptr () -> (Ptr (Ptr ()) -> IO Bool) -> IO Bool
forall b a c.
Storable b =>
(a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c
withManyArray0 Text -> (Ptr () -> IO Bool) -> IO Bool
MWithCValFunc Text
forall t. Marshal t => MWithCValFunc t
mWithCVal ((FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
T.pack (FilePath
progFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
args)) Ptr ()
forall a. Ptr a
nullPtr
        (Ptr HsQMLStringHandle -> IO Bool
hsqmlSetArgs (Ptr HsQMLStringHandle -> IO Bool)
-> (Ptr (Ptr ()) -> Ptr HsQMLStringHandle)
-> Ptr (Ptr ())
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr (Ptr ()) -> Ptr HsQMLStringHandle
forall a b. Ptr a -> Ptr b
castPtr)

-- | Gets the program name and any command line arguments remaining from an
-- earlier call to 'setQtArgs' once Qt has removed any it understands, leaving
-- only application specific arguments.
getQtArgs :: RunQML (String, [String])
getQtArgs :: RunQML (FilePath, [FilePath])
getQtArgs = IO (FilePath, [FilePath]) -> RunQML (FilePath, [FilePath])
forall a. IO a -> RunQML a
RunQML IO (FilePath, [FilePath])
getQtArgsIO

getQtArgsIO :: IO (String, [String])
getQtArgsIO :: IO (FilePath, [FilePath])
getQtArgsIO = do
    Int
argc <- IO Int
hsqmlGetArgsCount
    (Text
 -> (Ptr () -> IO (FilePath, [FilePath]))
 -> IO (FilePath, [FilePath]))
-> [Text]
-> Ptr ()
-> (Ptr (Ptr ()) -> IO (FilePath, [FilePath]))
-> IO (FilePath, [FilePath])
forall b a c.
Storable b =>
(a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c
withManyArray0 Text
-> (Ptr () -> IO (FilePath, [FilePath]))
-> IO (FilePath, [FilePath])
MWithCValFunc Text
forall t. Marshal t => MWithCValFunc t
mWithCVal (Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
argc (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
"") Ptr ()
forall a. Ptr a
nullPtr ((Ptr (Ptr ()) -> IO (FilePath, [FilePath]))
 -> IO (FilePath, [FilePath]))
-> (Ptr (Ptr ()) -> IO (FilePath, [FilePath]))
-> IO (FilePath, [FilePath])
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
argv -> do
        Ptr HsQMLStringHandle -> IO ()
hsqmlGetArgs (Ptr HsQMLStringHandle -> IO ()) -> Ptr HsQMLStringHandle -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr (Ptr ()) -> Ptr HsQMLStringHandle
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr ())
argv
        [Ptr ()]
argvs <- Ptr () -> Ptr (Ptr ()) -> IO [Ptr ()]
forall a. (Storable a, Eq a) => a -> Ptr a -> IO [a]
peekArray0 Ptr ()
forall a. Ptr a
nullPtr Ptr (Ptr ())
argv
        Just (FilePath
arg0:[FilePath]
args) <- MaybeT IO [FilePath] -> IO (Maybe [FilePath])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [FilePath] -> IO (Maybe [FilePath]))
-> MaybeT IO [FilePath] -> IO (Maybe [FilePath])
forall a b. (a -> b) -> a -> b
$ (Ptr () -> MaybeT IO FilePath) -> [Ptr ()] -> MaybeT IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Text -> FilePath) -> MaybeT IO Text -> MaybeT IO FilePath
forall a b. (a -> b) -> MaybeT IO a -> MaybeT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack (MaybeT IO Text -> MaybeT IO FilePath)
-> (Ptr () -> MaybeT IO Text) -> Ptr () -> MaybeT IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr () -> MaybeT IO Text
forall t. Marshal t => MFromCValFunc t
mFromCVal) [Ptr ()]
argvs
        (FilePath, [FilePath]) -> IO (FilePath, [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
arg0, [FilePath]
args)

-- | Represents a Qt application flag.
data QtFlag
    -- | Enables resource sharing between OpenGL contexts. This must be set in
    -- order to use QtWebEngine. 
    = QtShareOpenGLContexts
    | QtEnableQMLDebug
    deriving Int -> QtFlag -> ShowS
[QtFlag] -> ShowS
QtFlag -> FilePath
(Int -> QtFlag -> ShowS)
-> (QtFlag -> FilePath) -> ([QtFlag] -> ShowS) -> Show QtFlag
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QtFlag -> ShowS
showsPrec :: Int -> QtFlag -> ShowS
$cshow :: QtFlag -> FilePath
show :: QtFlag -> FilePath
$cshowList :: [QtFlag] -> ShowS
showList :: [QtFlag] -> ShowS
Show

internalFlag :: QtFlag -> HsQMLGlobalFlag
internalFlag :: QtFlag -> HsQMLGlobalFlag
internalFlag QtFlag
QtShareOpenGLContexts = HsQMLGlobalFlag
HsqmlGflagShareOpenglContexts
internalFlag QtFlag
QtEnableQMLDebug = HsQMLGlobalFlag
HsqmlGflagEnableQmlDebug

-- | Sets or clears one of the application flags used by Qt and returns True
-- if successful. If the flag or flag value is not supported then it will
-- return False. Setting flags once the Qt event loop is entered is
-- unsupported and will also cause this function to return False.
setQtFlag :: QtFlag -> Bool -> IO Bool
setQtFlag :: QtFlag -> Bool -> IO Bool
setQtFlag QtFlag
flag Bool
val = do
    IO ()
hsqmlInit
    HsQMLGlobalFlag -> Bool -> IO Bool
hsqmlSetFlag (QtFlag -> HsQMLGlobalFlag
internalFlag QtFlag
flag) Bool
val

-- | Gets the state of one of the application flags used by Qt.
getQtFlag :: QtFlag -> RunQML Bool
getQtFlag :: QtFlag -> RunQML Bool
getQtFlag = IO Bool -> RunQML Bool
forall a. IO a -> RunQML a
RunQML (IO Bool -> RunQML Bool)
-> (QtFlag -> IO Bool) -> QtFlag -> RunQML Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsQMLGlobalFlag -> IO Bool
hsqmlGetFlag (HsQMLGlobalFlag -> IO Bool)
-> (QtFlag -> HsQMLGlobalFlag) -> QtFlag -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QtFlag -> HsQMLGlobalFlag
internalFlag

-- | Shuts down and frees resources used by the Qt framework, preventing
-- further use of the event loop. The framework is initialised when
-- 'runEventLoop' is first called and remains initialised afterwards so that
-- the event loop can be reentered if desired (e.g. when using GHCi). Once
-- shut down, the framework cannot be reinitialised.
--
-- It is recommended that you call this function at the end of your program as
-- this library will try, but cannot guarantee in all configurations to be able
-- to shut it down for you. Failing to shutdown the framework has been known to
-- intermittently cause crashes on process exit on some platforms.
--
-- This function must be called from the event loop thread and the event loop
-- must not be running at the time otherwise an 'EventLoopException' will be
-- thrown.
shutdownQt :: IO ()
shutdownQt :: IO ()
shutdownQt = do
    HsQMLEventLoopStatus
status <- IO HsQMLEventLoopStatus
hsqmlEvloopShutdown
    case HsQMLEventLoopStatus -> Maybe EventLoopException
statusException HsQMLEventLoopStatus
status of
        Just EventLoopException
ex -> EventLoopException -> IO ()
forall a e. Exception e => e -> a
throw EventLoopException
ex
        Maybe EventLoopException
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

statusException :: HsQMLEventLoopStatus -> Maybe EventLoopException
statusException :: HsQMLEventLoopStatus -> Maybe EventLoopException
statusException HsQMLEventLoopStatus
HsqmlEvloopOk = Maybe EventLoopException
forall a. Maybe a
Nothing
statusException HsQMLEventLoopStatus
HsqmlEvloopAlreadyRunning = EventLoopException -> Maybe EventLoopException
forall a. a -> Maybe a
Just EventLoopException
EventLoopAlreadyRunning
statusException HsQMLEventLoopStatus
HsqmlEvloopPostShutdown = EventLoopException -> Maybe EventLoopException
forall a. a -> Maybe a
Just EventLoopException
EventLoopPostShutdown
statusException HsQMLEventLoopStatus
HsqmlEvloopWrongThread = EventLoopException -> Maybe EventLoopException
forall a. a -> Maybe a
Just EventLoopException
EventLoopWrongThread
statusException HsQMLEventLoopStatus
HsqmlEvloopNotRunning = EventLoopException -> Maybe EventLoopException
forall a. a -> Maybe a
Just EventLoopException
EventLoopNotRunning
statusException HsQMLEventLoopStatus
_ = EventLoopException -> Maybe EventLoopException
forall a. a -> Maybe a
Just EventLoopException
EventLoopOtherError

-- | Exception type used to report errors pertaining to the event loop.
data EventLoopException
    = EventLoopAlreadyRunning
    | EventLoopPostShutdown
    | EventLoopWrongThread
    | EventLoopNotRunning
    | EventLoopOtherError
    deriving (Int -> EventLoopException -> ShowS
[EventLoopException] -> ShowS
EventLoopException -> FilePath
(Int -> EventLoopException -> ShowS)
-> (EventLoopException -> FilePath)
-> ([EventLoopException] -> ShowS)
-> Show EventLoopException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EventLoopException -> ShowS
showsPrec :: Int -> EventLoopException -> ShowS
$cshow :: EventLoopException -> FilePath
show :: EventLoopException -> FilePath
$cshowList :: [EventLoopException] -> ShowS
showList :: [EventLoopException] -> ShowS
Show, Typeable)

instance Exception EventLoopException

-- | Path to a QML document file.
newtype DocumentPath = DocumentPath String

-- | Converts a local file path into a 'DocumentPath'.
fileDocument :: FilePath -> DocumentPath
fileDocument :: FilePath -> DocumentPath
fileDocument FilePath
fp =
    let ds :: [FilePath]
ds = FilePath -> [FilePath]
splitDirectories FilePath
fp
        isAbs :: Bool
isAbs = FilePath -> Bool
isAbsolute FilePath
fp
        fixHead :: ShowS
fixHead =
            (\FilePath
cs -> if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
cs then [] else Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:FilePath
cs) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FilePath
pathSeparators)
        mapHead :: (a -> a) -> [a] -> [a]
mapHead a -> a
_ [] = []
        mapHead a -> a
f (a
x:[a]
xs) = a -> a
f a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
        afp :: FilePath
afp = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ ShowS -> [FilePath] -> [FilePath]
forall {a}. (a -> a) -> [a] -> [a]
mapHead ShowS
fixHead [FilePath]
ds
        rfp :: FilePath
rfp = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/" [FilePath]
ds
    in FilePath -> DocumentPath
DocumentPath (FilePath -> DocumentPath) -> FilePath -> DocumentPath
forall a b. (a -> b) -> a -> b
$ if Bool
isAbs then FilePath
"file://" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
afp else FilePath
rfp

-- | Converts a URI string into a 'DocumentPath'.
uriDocument :: String -> DocumentPath
uriDocument :: FilePath -> DocumentPath
uriDocument = FilePath -> DocumentPath
DocumentPath