module Graphics.QML.Engine (
InitialWindowState(
ShowWindow,
ShowWindowWithTitle,
HideWindow),
EngineConfig(
EngineConfig,
initialURL,
initialWindowState,
contextObject),
defaultEngineConfig,
createEngine,
runEngines,
filePathToURI
) where
import Graphics.QML.Internal.Marshal
import Graphics.QML.Internal.Objects
import Graphics.QML.Internal.Engine
import Graphics.QML.Marshal
import Graphics.QML.Objects
import Data.List
import Data.Maybe
import Data.Typeable
import Foreign.Storable
import System.FilePath (isAbsolute, splitDirectories, pathSeparators)
import Network.URI (URI(URI), URIAuth(URIAuth), nullURI, uriPath)
data InitialWindowState
= ShowWindow
| ShowWindowWithTitle String
| HideWindow
data EngineConfig a = EngineConfig {
initialURL :: URI,
initialWindowState :: InitialWindowState,
contextObject :: Maybe (ObjRef a)
}
defaultEngineConfig :: EngineConfig a
defaultEngineConfig = EngineConfig {
initialURL = nullURI {uriPath = "main.qml"},
initialWindowState = ShowWindow,
contextObject = Nothing
}
isWindowShown :: InitialWindowState -> Bool
isWindowShown ShowWindow = True
isWindowShown (ShowWindowWithTitle _) = True
isWindowShown HideWindow = False
getWindowTitle :: InitialWindowState -> Maybe String
getWindowTitle (ShowWindowWithTitle t) = Just t
getWindowTitle _ = Nothing
createEngine :: (Object a) => EngineConfig a -> IO ()
createEngine config = do
hsqmlInit
let hndl = fmap (\(ObjRef h) -> h) $ contextObject config
url = initialURL config
state = initialWindowState config
showWin = isWindowShown state
maybeTitle = getWindowTitle state
setTitle = isJust maybeTitle
titleStr = fromMaybe "" maybeTitle
mOutAlloc url $ \urlPtr -> do
mOutAlloc titleStr $ \titlePtr -> do
hsqmlCreateEngine hndl urlPtr showWin setTitle titlePtr
runEngines :: IO ()
runEngines = do
hsqmlInit
hsqmlRun
filePathToURI :: FilePath -> URI
filePathToURI fp =
let ds = splitDirectories fp
abs = isAbsolute fp
fixHead =
(\cs -> if null cs then [] else '/':cs) .
takeWhile (\c -> not $ c `elem` pathSeparators)
mapHead _ [] = []
mapHead f (x:xs) = f x : xs
afp = intercalate "/" $ mapHead fixHead ds
rfp = intercalate "/" ds
in if abs
then URI "file:" (Just $ URIAuth "" "" "") afp "" ""
else URI "" Nothing rfp "" ""