packages feed

hsqml-datamodel (empty) → 0.0.0.0

raw patch · 21 files changed

+1458/−0 lines, 21 filesdep +basedep +hsqmldep +template-haskellbuild-type:Customsetup-changed

Dependencies added: base, hsqml, template-haskell, text

Files

+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015, Marcin Mrotek+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of hsqml-datamodel nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,359 @@+#!/usr/bin/runhaskell +{-# LANGUAGE TemplateHaskell #-}+module Main where++import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Distribution.Simple+import Distribution.Simple.Compiler+import Distribution.Simple.BuildPaths+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program+import Distribution.Simple.Program.Ld+import Distribution.Simple.Register+import Distribution.Simple.Setup+import Distribution.Simple.Utils+import Distribution.Text+import Distribution.Verbosity+import qualified Distribution.InstalledPackageInfo as I+import qualified Distribution.ModuleName as ModuleName+import Distribution.PackageDescription+import Language.Haskell.TH+import System.Environment+import qualified System.Info as Info+import System.FilePath++-- Use Template Haskell to support different versions of the Cabal API+$(let+    post4700BaseAPI = Info.compilerVersion >= Version [7,7] []+    post118CabalAPI = cabalVersion >= Version [1,17,0] []+    post122CabalAPI = cabalVersion >= Version [1,21,0] []+    vnameE = VarE . mkName+    vnameP = VarP . mkName+    cnameE = ConE . mkName+    app2E f x y = AppE (AppE f x) y+    app3E f x y z = AppE (app2E f x y) z+    app4E f x y z u = AppE (app3E f x y z) u+    app5E f x y z u v = AppE (app4E f x y z u) v+    nothingE = cnameE "Nothing"+    falseE = cnameE "False"+    -- 'setEnv' function was added in base 4.7.0.0+    setEnvShim = if post4700BaseAPI+        then vnameE "setEnv"+        else LamE [WildP, WildP] $ AppE (vnameE "return") (cnameE "()")+    -- 'LocalBuildInfo' record changed fields in Cabal 1.18+    extractCLBI = if post118CabalAPI+        then app2E (vnameE "getComponentLocalBuildInfo")+            (vnameE "x") (cnameE "CLibName")+        else AppE (vnameE "fromJust") $ AppE (vnameE "libraryConfig")+            (vnameE "x")+    -- 'programFindLocation' field changed signature in Cabal 1.18+    adaptFindLoc = if post118CabalAPI+        then LamE [vnameP "f", vnameP "x", WildP] $+            AppE (vnameE "f") (vnameE "x")+        else vnameE "id"+    -- 'rawSystemStdInOut' function changed signature in Cabal 1.18+    rawSystemStdErr = if post118CabalAPI+        then app4E (app3E (vnameE "rawSystemStdInOut")+            (vnameE "v") (vnameE "p") (vnameE "a"))+            nothingE nothingE nothingE falseE +        else app5E (vnameE "rawSystemStdInOut")+            (vnameE "v") (vnameE "p") (vnameE "a") nothingE falseE+    -- 'programPostConf' field changed signature in Cabal 1.18+    noPostConf = if post118CabalAPI+        then LamE [WildP, vnameP "c"] $ AppE (vnameE "return") (vnameE "c")+        else LamE [WildP, WildP] $ AppE (vnameE "return") (cnameE "[]")+    -- 'generateRegistrationInfo' function changed signature in Cabal 1.22+    genRegInfo = if post122CabalAPI+        then LamE [vnameP "pdb"] $ app2E (vnameE ">>=")+                (AppE (vnameE "absolutePackageDBPaths") (vnameE "pdb")) $+            LamE [vnameP "apdb"] $+            app5E (app4E (vnameE "generateRegistrationInfo")+                (vnameE "verb") (vnameE "pkg") (vnameE "lib") (vnameE "lbi"))+                (vnameE "clbi") (vnameE "inp")+                (AppE (vnameE "relocatable") (vnameE "lbi")) (vnameE "dir")+                (AppE (vnameE "registrationPackageDB") (vnameE "apdb"))+        else LamE [WildP] $ app3E (app4E (vnameE "generateRegistrationInfo")+            (vnameE "verb") (vnameE "pkg") (vnameE "lib") (vnameE "lbi"))+            (vnameE "clbi") (vnameE "inp") (vnameE "dir")+    in return [+        FunD (mkName "setEnvShim") [+            Clause [] (NormalB setEnvShim) []],+        FunD (mkName "extractCLBI") [+            Clause [vnameP "x"] (NormalB extractCLBI) []],+        FunD (mkName "adaptFindLoc") [+            Clause [] (NormalB adaptFindLoc) []],+        FunD (mkName "rawSystemStdErr") [+            Clause [vnameP "v", vnameP "p", vnameP "a"] (+                NormalB rawSystemStdErr) []],+        FunD (mkName "noPostConf") [+            Clause [] (NormalB noPostConf) []],+        FunD (mkName "genRegInfo") [+            Clause [vnameP "verb", vnameP "pkg", vnameP "lib", vnameP "lbi",+                vnameP "clbi", vnameP "inp", vnameP "dir"] (+                    NormalB genRegInfo) []]])++main :: IO ()+main = do+  -- If system uses qtchooser(1) then encourage it to choose Qt 5+  env <- getEnvironment+  case lookup "QT_SELECT" env of+    Nothing -> setEnvShim "QT_SELECT" "5"+    _       -> return ()+  -- Chain standard setup+  defaultMainWithHooks simpleUserHooks {+    confHook = confWithQt, buildHook = buildWithQt,+    copyHook = copyWithQt, instHook = instWithQt,+    regHook = regWithQt}++getCustomStr :: String -> PackageDescription -> String+getCustomStr name pkgDesc =+  fromMaybe "" $ do+    lib <- library pkgDesc+    lookup name $ customFieldsBI $ libBuildInfo lib++getCustomFlag :: String -> PackageDescription -> Bool+getCustomFlag name pkgDesc =+  fromMaybe False . simpleParse $ getCustomStr name pkgDesc++xForceGHCiLib, xMocHeaders, xFrameworkDirs, xSeparateCbits :: String+xForceGHCiLib  = "x-force-ghci-lib"+xMocHeaders    = "x-moc-headers"+xFrameworkDirs = "x-framework-dirs"+xSeparateCbits = "x-separate-cbits"++confWithQt :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags ->+  IO LocalBuildInfo+confWithQt (gpd,hbi) flags = do+  let verb = fromFlag $ configVerbosity flags+  mocPath <- findProgramLocation verb "moc"+  cppPath <- findProgramLocation verb "cpp"+  let mapLibBI = fmap . mapCondTree . mapBI $ substPaths mocPath cppPath+      gpd' = gpd {+        condLibrary = mapLibBI $ condLibrary gpd,+        condExecutables = mapAllBI mocPath cppPath $ condExecutables gpd,+        condTestSuites = mapAllBI mocPath cppPath $ condTestSuites gpd,+        condBenchmarks = mapAllBI mocPath cppPath $ condBenchmarks gpd}+  lbi <- confHook simpleUserHooks (gpd',hbi) flags+  -- Find Qt moc program and store in database+  (_,_,db') <- requireProgramVersion verb+    mocProgram qtVersionRange (withPrograms lbi)+  -- Force enable GHCi workaround library if flag set and not using shared libs+  let forceGHCiLib =+        (getCustomFlag xForceGHCiLib $ localPkgDescr lbi) &&+        (not $ withSharedLib lbi)+  -- Update LocalBuildInfo+  return lbi {withPrograms = db',+              withGHCiLib = withGHCiLib lbi || forceGHCiLib}++mapAllBI :: (HasBuildInfo a) => Maybe FilePath -> Maybe FilePath ->+  [(x, CondTree c v a)] -> [(x, CondTree c v a)]+mapAllBI mocPath cppPath =+  mapSnd . mapCondTree . mapBI $ substPaths mocPath cppPath++mapCondTree :: (a -> a) -> CondTree v c a -> CondTree v c a+mapCondTree f (CondNode val cnstr cs) =+  CondNode (f val) cnstr $ map updateChildren cs+  where updateChildren (cond,left,right) =+          (cond, mapCondTree f left, fmap (mapCondTree f) right)++substPaths :: Maybe FilePath -> Maybe FilePath -> BuildInfo -> BuildInfo+substPaths mocPath cppPath build =+  let toRoot = takeDirectory . takeDirectory . fromMaybe ""+      substPath = replace "/QT_ROOT" (toRoot mocPath) .+        replace "/SYS_ROOT" (toRoot cppPath)+  in build {ccOptions = map substPath $ ccOptions build,+            ldOptions = map substPath $ ldOptions build,+            extraLibDirs = map substPath $ extraLibDirs build,+            includeDirs = map substPath $ includeDirs build,+            options = mapSnd (map substPath) $ options build,+            customFieldsBI = mapSnd substPath $ customFieldsBI build}++buildWithQt ::+  PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+buildWithQt pkgDesc lbi hooks flags = do+    let verb = fromFlag $ buildVerbosity flags+    libs' <- maybeMapM (\lib -> fmap (\lib' ->+      lib {libBuildInfo = lib'}) $ fixQtBuild verb lbi $ libBuildInfo lib) $+      library pkgDesc+    let pkgDesc' = pkgDesc {library = libs'}+        lbi' = if (needsGHCiFix pkgDesc lbi)+                 then lbi {withGHCiLib = False, splitObjs = False} else lbi+    buildHook simpleUserHooks pkgDesc' lbi' hooks flags+    case libs' of+      Just lib -> when (needsGHCiFix pkgDesc lbi) $+        buildGHCiFix verb pkgDesc lbi lib+      Nothing  -> return ()++fixQtBuild :: Verbosity -> LocalBuildInfo -> BuildInfo -> IO BuildInfo+fixQtBuild verb lbi build = do+  let moc  = fromJust $ lookupProgram mocProgram $ withPrograms lbi+      option name = words $ fromMaybe "" $ lookup name $ customFieldsBI build+      incs = option xMocHeaders+      bDir = buildDir lbi+      cpps = map (\inc ->+        bDir </> (takeDirectory inc) </>+        ("moc_" ++ (takeBaseName inc) ++ ".cpp")) incs+      args = map ("-I"++) (includeDirs build) +++             map ("-F"++) (option xFrameworkDirs)+  -- Run moc on each of the header files containing QObject subclasses+  mapM_ (\(i,o) -> do+      createDirectoryIfMissingVerbose verb True (takeDirectory o)+      runProgram verb moc $ [i,"-o",o] ++ args) $ zip incs cpps+  -- Add the moc generated source files to be compiled+  return build {cSources = cpps ++ cSources build,+                ccOptions = "-fPIC" : ccOptions build}++needsGHCiFix :: PackageDescription -> LocalBuildInfo -> Bool+needsGHCiFix pkgDesc lbi =+  withGHCiLib lbi && getCustomFlag xSeparateCbits pkgDesc++mkGHCiFixLibPkgId :: PackageDescription -> PackageIdentifier+mkGHCiFixLibPkgId pkgDesc =+  let pid = packageId pkgDesc+      (PackageName name) = pkgName pid+  in pid {pkgName = PackageName $ "cbits-" ++ name}++mkGHCiFixLibName :: PackageDescription -> String+mkGHCiFixLibName pkgDesc =+  ("lib" ++ display (mkGHCiFixLibPkgId pkgDesc)) <.> dllExtension++mkGHCiFixLibRefName :: PackageDescription -> String+mkGHCiFixLibRefName pkgDesc =+  prefix ++ display (mkGHCiFixLibPkgId pkgDesc)+  where prefix = if dllExtension == "dll" then "lib" else ""++buildGHCiFix ::+  Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> IO ()+buildGHCiFix verb pkgDesc lbi lib = do+  let bDir = buildDir lbi+      ms = map ModuleName.toFilePath $ libModules lib+      hsObjs = map ((bDir </>) . (<.> "o")) ms+  stubObjs <- fmap catMaybes $+    mapM (findFileWithExtension ["o"] [bDir]) $ map (++ "_stub") ms+  (ld,_) <- requireProgram verb ldProgram (withPrograms lbi)+  combineObjectFiles verb ld+    (bDir </> (("HS" ++) $ display $ packageId pkgDesc) <.> "o")+    (stubObjs ++ hsObjs)+  (ghc,_) <- requireProgram verb ghcProgram (withPrograms lbi)+  let bi = libBuildInfo lib+  runProgram verb ghc (+    ["-shared","-o",bDir </> (mkGHCiFixLibName pkgDesc)] +++    (ldOptions bi) ++ (map ("-l" ++) $ extraLibs bi) +++    (map ("-L" ++) $ extraLibDirs bi) +++    (map ((bDir </>) . flip replaceExtension objExtension) $ cSources bi))+  return ()++mocProgram :: Program+mocProgram = Program {+  programName = "moc",+  programFindLocation = adaptFindLoc $+    \verb -> findProgramLocation verb "moc",+  programFindVersion = \verb path -> do+    (oLine,eLine,_) <- rawSystemStdErr verb path ["-v"]+    return $+      (findSubseq (stripPrefix "(Qt ") eLine `mplus`+       findSubseq (stripPrefix "moc ") oLine) >>=+      simpleParse . takeWhile (\c -> isDigit c || c == '.'),+  programPostConf = noPostConf+}++qtVersionRange :: VersionRange+qtVersionRange = intersectVersionRanges+  (orLaterVersion $ Version [5,0] []) (earlierVersion $ Version [6,0] [])++copyWithQt ::+  PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()+copyWithQt pkgDesc lbi hooks flags = do+  copyHook simpleUserHooks pkgDesc lbi hooks flags+  let verb = fromFlag $ copyVerbosity flags+      dest = fromFlag $ copyDest flags+      bDir = buildDir lbi+      libDir = libdir $ absoluteInstallDirs pkgDesc lbi dest+      file = mkGHCiFixLibName pkgDesc+  when (needsGHCiFix pkgDesc lbi) $+    installOrdinaryFile verb (bDir </> file) (libDir </> file)++regWithQt :: +  PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()+regWithQt pkg@PackageDescription { library = Just lib } lbi _ flags = do+  let verb    = fromFlag $ regVerbosity flags+      inplace = fromFlag $ regInPlace flags+      dist    = fromFlag $ regDistPref flags+      pkgDb   = withPackageDB lbi+      clbi    = extractCLBI lbi+  instPkgInfo <- genRegInfo verb pkg lib lbi clbi inplace dist pkgDb+  let instPkgInfo' = instPkgInfo {+        -- Add extra library for GHCi workaround+        I.extraGHCiLibraries =+          (if needsGHCiFix pkg lbi then [mkGHCiFixLibRefName pkg] else []) +++            I.extraGHCiLibraries instPkgInfo,+        -- Add directories to framework search path+        I.frameworkDirs =+          words (getCustomStr xFrameworkDirs pkg) +++            I.frameworkDirs instPkgInfo}+  case flagToMaybe $ regGenPkgConf flags of+    Just regFile -> do+      writeUTF8File (fromMaybe (display (packageId pkg) <.> "conf") regFile) $+        I.showInstalledPackageInfo instPkgInfo'+    _ | fromFlag (regGenScript flags) ->+      die "Registration scripts are not implemented."+      | otherwise -> +      registerPackage verb instPkgInfo' pkg lbi inplace pkgDb+regWithQt pkgDesc _ _ flags =+  setupMessage (fromFlag $ regVerbosity flags) +    "Package contains no library to register:" (packageId pkgDesc)++instWithQt ::+  PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()+instWithQt pkgDesc lbi hooks flags = do+  let copyFlags = defaultCopyFlags {+        copyDistPref   = installDistPref flags,+        copyVerbosity  = installVerbosity flags+      }+      regFlags = defaultRegisterFlags {+        regDistPref  = installDistPref flags,+        regInPlace   = installInPlace flags,+        regPackageDB = installPackageDB flags,+        regVerbosity = installVerbosity flags+      }+  copyWithQt pkgDesc lbi hooks copyFlags+  when (hasLibs pkgDesc) $ regWithQt pkgDesc lbi hooks regFlags++class HasBuildInfo a where+  mapBI :: (BuildInfo -> BuildInfo) -> a -> a++instance HasBuildInfo Library where+  mapBI f x = x {libBuildInfo = f $ libBuildInfo x} ++instance HasBuildInfo Executable where+  mapBI f x = x {buildInfo = f $ buildInfo x} ++instance HasBuildInfo TestSuite where+  mapBI f x = x {testBuildInfo = f $ testBuildInfo x} ++instance HasBuildInfo Benchmark where+  mapBI f x = x {benchmarkBuildInfo = f $ benchmarkBuildInfo x} ++maybeMapM :: (Monad m) => (a -> m b) -> (Maybe a) -> m (Maybe b)+maybeMapM f = maybe (return Nothing) $ liftM Just . f++mapSnd :: (a -> a) -> [(x, a)] -> [(x, a)]+mapSnd f = map (\(x,y) -> (x,f y))++findSubseq :: ([a] -> Maybe b) -> [a] -> Maybe b+findSubseq f [] = f []+findSubseq f xs@(_:ys) =+  case f xs of+    Nothing -> findSubseq f ys+    Just r  -> Just r++replace :: (Eq a) => [a] -> [a] -> [a] -> [a]+replace [] _ xs = xs+replace _ _ [] = []+replace src dst xs@(x:xs') =+  case stripPrefix src xs of+    Just xs'' -> dst ++ replace src dst xs''+    Nothing  -> x : replace src dst xs'
+ cbits/HaskellModel.cpp view
@@ -0,0 +1,91 @@+#include "HaskellModel.h"++#include <sstream>++HaskellModel::HaskellModel(QObject* parent) : QAbstractTableModel(parent) {+}++HaskellModel::~HaskellModel() {+}++int HaskellModel::rowCount(const QModelIndex & parent) const {+    if (parent.isValid()) {+        return 0;+    } else if (delegates[delegateHandle].callbacks && delegates[delegateHandle].callbacks->rowCountCb) {+        return delegates[delegateHandle].callbacks->rowCountCb();+    } else {+        return 0;+    }+} ++int HaskellModel::columnCount(const QModelIndex & parent) const {+  if (delegates[delegateHandle].callbacks && delegates[delegateHandle].callbacks->columnCountCb) {+    return delegates[delegateHandle].callbacks->columnCountCb();+  } else {+    return 0;+  }+}++QVariant HaskellModel::data(const QModelIndex & parent, int role) const {+    QVariant* ptr;+    if ((Qt::UserRole <= role) && parent.isValid() && delegates[delegateHandle].callbacks && delegates[delegateHandle].callbacks->dataCb) {+     ptr = reinterpret_cast<QVariant*>(delegates[delegateHandle].callbacks->dataCb(parent.row(), role - Qt::UserRole));+     QVariant value = *ptr;+     delete ptr;+     return value;+   } else {+     return QVariant();+   }+} ++QVariant HaskellModel::headerData(int column, Qt::Orientation, int role) {+  if((Qt::DisplayRole == role) && delegates[delegateHandle].callbacks && delegates[delegateHandle].callbacks->headerDataCb) {+    return delegates[delegateHandle].callbacks->headerDataCb(column);+  } else {+    return QVariant();+  }+}++int HaskellModel::delegate() const {+    return delegateHandle;+}++void HaskellModel::setDelegate(int handle) {+    delegateHandle = handle;+}++QHash<int,QByteArray> HaskellModel::roleNames() const {+  return delegates[delegateHandle].roles;+}++/* static */ HaskellModelDelegateHandle HaskellModel::registerDelegate() {+  HaskellModelDelegate dlg;+  dlg.callbacks = NULL;+  dlg.roles = QHash<int,QByteArray>();+  delegates.push_back(dlg);+  return delegates.size() - 1;+}++/* static */ void HaskellModel::unregisterDelegate(HaskellModelDelegateHandle hndl) {+  delegates[hndl].callbacks = NULL;+}++/* static */ void HaskellModel::setCallbacks+    ( HaskellModelDelegateHandle hndl+    , HaskellModelCallbacks* cbs+    ) {+  delegates[hndl].callbacks = cbs;+}++/* static */ void HaskellModel::addRole+    ( HaskellModelDelegateHandle hndl+    , int key+    , char* value+    ) {+  delegates[hndl].roles[Qt::UserRole + key] = value;+}++/* static */ std::vector<HaskellModelDelegate> HaskellModel::delegates+  = std::vector<HaskellModelDelegate>();++
+ cbits/HaskellModel.h view
@@ -0,0 +1,52 @@+#ifndef HASKELL_MODEL_H+#define HASKELL_MODEL_H++#include "interface.h"++#include <QtCore/QAbstractTableModel>++#include <vector>++struct HaskellModelDelegate {+  HaskellModelCallbacks* callbacks;+  QHash<int,QByteArray> roles;+};++class HaskellModel : public QAbstractTableModel {+    Q_OBJECT+    Q_PROPERTY(int delegate READ delegate WRITE setDelegate)+  public:+    HaskellModel(QObject* parent = 0);+    ~HaskellModel();++    int rowCount(const QModelIndex &) const;+    int columnCount(const QModelIndex &) const;+    QVariant data(const QModelIndex &, int) const; +    QVariant headerData(int, Qt::Orientation, int);++    int delegate() const;+    void setDelegate(int);+    int instance();++    QHash<int,QByteArray> roleNames() const;++    Q_INVOKABLE QModelIndex refresh() {+      emit dataChanged(index(0,0), index(rowCount(QModelIndex())-1, columnCount(QModelIndex())-1));+    };++  private:+    int32_t delegateHandle;++ /* static */+  public:+    static HaskellModelDelegateHandle registerDelegate();+    static void unregisterDelegate(HaskellModelDelegateHandle);+    static void setCallbacks(HaskellModelDelegateHandle, HaskellModelCallbacks*);+    static void addRole(HaskellModelDelegateHandle, int, char*);++  private:+    static std::vector<HaskellModelDelegate> delegates;+};++#endif+
+ cbits/interface.cpp view
@@ -0,0 +1,49 @@+#include "interface.h"+#include "HaskellModel.h"++#include <cstdio>++#include <QtQml/QtQml>+#include <string>+#include <sstream>++void registerHaskellModel() {+  qmlRegisterType<HaskellModel> ("HsQML.HaskellModel", 1, 0, "HaskellModel");+} ++HaskellModelDelegateHandle registerHaskellModelDelegate() {+  return HaskellModel::registerDelegate();+}++void unregisterHaskellModelDelegate(HaskellModelDelegateHandle hndl) {+  HaskellModel::unregisterDelegate(hndl);+}++void setHaskellModelCallbacks(HaskellModelDelegateHandle hndl, HaskellModelCallbacks* cbs) {+  HaskellModel::setCallbacks(hndl, cbs);+}++void addHaskellModelRole(HaskellModelDelegateHandle hndl, int key, char* value) {+  HaskellModel::addRole(hndl, key, value);+}++QtVariant newQtInt(int v) {+  return reinterpret_cast<QtVariant>(new QVariant(v));+}++QtVariant newQtDouble(double v) {+  return reinterpret_cast<QtVariant>(new QVariant(v));+} ++QtVariant newQtText(char* v) {+  return reinterpret_cast<QtVariant>(new QVariant(v));+} ++QtVariant newQtBool(int v) {+  return reinterpret_cast<QtVariant>(new QVariant((bool)v));+}++QtVariant newQtNull() {+  return reinterpret_cast<QtVariant>(new QVariant());+}+
+ cbits/interface.h view
@@ -0,0 +1,32 @@+#ifndef HASKELL_MODEL_INTERFACE_H+#define HASKELL_MODEL_INTERFACE_H++#include <stdint.h>++#include <QtCore/QHash>++#include "types.h"++#ifdef __cplusplus+extern "C" {+#endif++void registerHaskellModel();++HaskellModelDelegateHandle registerHaskellModelDelegate();+void unregisterHaskellModelDelegate(HaskellModelDelegateHandle);++void setHaskellModelCallbacks(HaskellModelDelegateHandle, HaskellModelCallbacks*);+void addHaskellModelRole(HaskellModelDelegateHandle, int, char*);++QtVariant newQtInt(int);+QtVariant newQtDouble(double);+QtVariant newQtText(char*);+QtVariant newQtBool(int);+QtVariant newQtNull();++#ifdef __cplusplus+}+#endif++#endif // HASKELL_MODEL_INTERFACE_H
+ cbits/types.h view
@@ -0,0 +1,29 @@+#ifndef HASKELL_MODEL_TYPES_H+#define HASKELL_MODEL_TYPES_H++#include <stdint.h>++#ifdef __cplusplus+extern "C" {+#endif++typedef char* QtVariant;+typedef int (*rowCountCallback) ();+typedef int (*columnCountCallback) ();+typedef QtVariant (*dataCallback) (int,int);+typedef QtVariant (*headerDataCallback) (int);++typedef struct {+   rowCountCallback    rowCountCb;+   columnCountCallback columnCountCb;+   dataCallback        dataCb;+   headerDataCallback  headerDataCb;+} HaskellModelCallbacks;++typedef int32_t HaskellModelDelegateHandle;++#ifdef __cplusplus+}+#endif++#endif // HASKELL_MODEL_TYPES
+ hsqml-datamodel.cabal view
@@ -0,0 +1,85 @@+name:                hsqml-datamodel+version:             0.0.0.0+synopsis:            HsQML (Qt5) data model.+description:         HsQML (Qt5) data model. Use any collection (actually, any (Int -> IO a) action) of single constructor data types as a model for use with QML views.+license:             BSD3+license-file:        LICENSE+author:              Marcin Mrotek+maintainer:          marcin.jan.mrotek@gmail.com+-- copyright:           +category:            Graphics+build-type:          Custom+Extra-source-files:+    cbits/*.cpp cbits/*.h +cabal-version:       >=1.10+homepage:        https://github.com/marcinmrotek/hsqml-datamodel+source-repository head+   type: git+   location: https://github.com/marcinmrotek/hsqml-datamodel.git++Flag UsePkgConfig+    Description:+        Use pkg-config for libraries instead of the platform default mechanism.+    Default: False++Flag devel+    description: Development mode (-Werror).+    default: False+    manual:  True++library+   exposed-modules:     Graphics.QML.DataModel.Internal.FFI+                        Graphics.QML.DataModel.Internal.FFI.Types+                        Graphics.QML.DataModel.Internal.Generic+                        Graphics.QML.DataModel.Internal.Generic.Get+                        Graphics.QML.DataModel.Internal.Generic.Set+                        Graphics.QML.DataModel.Internal.Generic.Count+                        Graphics.QML.DataModel.Internal.Generic.Mock+                        Graphics.QML.DataModel.Internal.Types+                        Graphics.QML.DataModel.TH+                        Graphics.QML.DataModel.Generic+                        Graphics.QML.DataModel.FFI+                        Graphics.QML.DataModel.Tutorial+                        Graphics.QML.DataModel+  build-depends:       base >=4.8 && <4.9+                     , hsqml+                     , text+                     , template-haskell+  hs-source-dirs:      src+  default-language:    Haskell2010+  include-dirs: cbits+  c-sources:+        cbits/interface.cpp+        cbits/HaskellModel.cpp+  x-moc-headers:+        cbits/HaskellModel.h+  x-separate-cbits: True+  build-tools: hsc2hs+  if os(windows) && !flag(UsePkgConfig)+        Include-dirs: /QT_ROOT/include+        Extra-libraries:+            Qt5Core, Qt5Gui, Qt5Widgets, Qt5Qml, Qt5Quick, stdc+++        Extra-lib-dirs: /SYS_ROOT/bin /QT_ROOT/bin+        if impl(ghc < 7.8)+            -- Pre-7.8 GHCi can't load eh_frame sections+            GHC-options: -optc-fno-asynchronous-unwind-tables+  else+        if os(darwin) && !flag(UsePkgConfig)+            Frameworks: QtCore QtGui QtWidgets QtQml QtQuick+            CC-options: -F /QT_ROOT/lib+            GHC-options: -framework-path /QT_ROOT/lib+            X-framework-dirs: /QT_ROOT/lib+        else+            Pkgconfig-depends:+                Qt5Core    >= 5.0 && < 6.0,+                Qt5Gui     >= 5.0 && < 6.0,+                Qt5Widgets >= 5.0 && < 6.0,+                Qt5Qml     >= 5.0 && < 6.0,+                Qt5Quick   >= 5.0 && < 6.0+        Extra-libraries: stdc+++  ghc-options: -Wall +  if flag(devel)+     ghc-options: -Werror+++
+ src/Graphics/QML/DataModel.hs view
@@ -0,0 +1,127 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE+    ExplicitForAll+  , ScopedTypeVariables+  #-}++{-|+Module      : Graphics.QML.DataModel+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++Main module. Should be enough for most uses.+-}+++module Graphics.QML.DataModel (+   registerHaskellModel+ , setupDataModel+ , finalizeDataModel+ , setRowCountCallback+ , setDataCallback+ , setHeaderDataCallback+ , DataModel+ , delegate+ , FFI.HmDelegateHandle+ , QtTable(..)+ , SetupColumns(..)+ , ColumnIndexException(..)+ , RowCountCallback + , DataCallback + , HeaderDataCallback +) where++import qualified Graphics.QML.DataModel.Internal.FFI as FFI+import Graphics.QML.DataModel.Internal.Types+import Graphics.QML.DataModel.Internal.Generic++import Control.Concurrent.MVar+import Control.Monad+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable++registerHaskellModel :: IO ()+-- ^Register the HaskellModel in QML's type system, so it can be used in .qml documents.+registerHaskellModel = FFI.c_registerHaskellModel++traverseCallbacks +  :: DataModel a +  -> (FFI.HmCallbacks -> IO FFI.HmCallbacks) +  -> IO ()+traverseCallbacks model action = withMVar (callbacks model)+  $ \cbs'ptr -> poke cbs'ptr =<< action =<< peek cbs'ptr++setupDataModel :: forall a. (SetupColumns a, CountFields a) => IO (DataModel a)+-- ^Create a data model handle that can be passed to HaskellModel.+setupDataModel = do+    cbs <- FFI.HmCallbacks +       <$> FFI.emptyRowCountCallback+       <*> makeColumnCountCallback (return $ countFields template)+       <*> FFI.emptyDataCallback+       <*> FFI.emptyHeaderDataCallback+    cbs'ptr <- malloc +    poke cbs'ptr cbs+    cbs'mv <- newMVar cbs'ptr+    dlg <- FFI.c_registerHaskellModelDelegate+    setupColumns dlg template+    FFI.c_setHaskellModelCallbacks dlg cbs'ptr+    return $ DataModel +      { callbacks = cbs'mv+      , delegate  = dlg+      }   +  where template :: sing a+        template = undefined++finalizeDataModel :: DataModel a -> IO ()+-- ^Free a data model handle.+finalizeDataModel model = do+  FFI.c_unregisterHaskellModelDelegate $ delegate model+  free =<< readMVar (callbacks model)++setRowCountCallback :: DataModel a -> RowCountCallback -> IO ()+-- ^Replace the row count callback of a data model handle.+setRowCountCallback model rowCb = traverseCallbacks model $ \cbs -> do+  freeHaskellFunPtr $ FFI.rowCountCallback cbs+  newRowCb <- makeRowCountCallback rowCb+  return cbs { FFI.rowCountCallback = newRowCb }++makeRowCountCallback :: RowCountCallback -> IO (FunPtr FFI.RowCountCallback)+makeRowCountCallback cb = FFI.c_createRowCountCallback $ fromIntegral <$> cb++{-+setColumnCountCallback :: DataModel a -> ColumnCountCallback -> IO ()+setColumnCountCallback model columnCb = traverseCallbacks model $ \cbs -> do+  freeHaskellFunPtr $ FFI.columnCountCallback cbs+  newColumnCb <- makeColumnCountCallback columnCb+  return cbs { FFI.columnCountCallback = newColumnCb }+-}++makeColumnCountCallback :: ColumnCountCallback -> IO (FunPtr FFI.ColumnCountCallback)+makeColumnCountCallback cb = FFI.c_createColumnCountCallback $ fromIntegral <$> cb++setDataCallback :: QtTable a => DataModel a -> DataCallback a -> IO ()+-- ^Replace the data callback of a data model handle.+setDataCallback model dataCb = traverseCallbacks model $ \cbs -> do +  freeHaskellFunPtr $ FFI.dataCallback cbs+  newDataCb <- makeDataCallback dataCb+  return cbs { FFI.dataCallback = newDataCb }+  +makeDataCallback :: QtTable a => DataCallback a -> IO (FunPtr FFI.DataCallback)+makeDataCallback cb = FFI.c_createDataCallback  +  $ \row column -> getColumn (fromIntegral column) =<< cb (fromIntegral row)++setHeaderDataCallback :: DataModel a -> HeaderDataCallback -> IO ()+-- ^Replace the header data callback of a data model handle. Not used by any QML views.+setHeaderDataCallback model headerDataCb = traverseCallbacks model $ \cbs -> do+  freeHaskellFunPtr $ FFI.headerDataCallback cbs+  newHeaderDataCb <- makeHeaderDataCallback headerDataCb+  return cbs { FFI.headerDataCallback = newHeaderDataCb }+  +makeHeaderDataCallback :: HeaderDataCallback -> IO (FunPtr FFI.HeaderDataCallback)+makeHeaderDataCallback cb = FFI.c_createHeaderDataCallback +  $ FFI.newQtString <=< cb <=< return.fromIntegral+
+ src/Graphics/QML/DataModel/FFI.hs view
@@ -0,0 +1,4 @@+module Graphics.QML.DataModel.FFI (addHaskellModelRole) where++import Graphics.QML.DataModel.Internal.FFI+
+ src/Graphics/QML/DataModel/Generic.hs view
@@ -0,0 +1,11 @@+module Graphics.QML.DataModel.Generic +  ( QtTable(..)+  , QtField(..)+  , Mock(..)+  , CountFields(..)+  , SetupColumns(..)+  , ColumnIndexException(..)+  ) where++import Graphics.QML.DataModel.Internal.Generic+
+ src/Graphics/QML/DataModel/Internal/FFI.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module Graphics.QML.DataModel.Internal.FFI (+    module Graphics.QML.DataModel.Internal.FFI+  , module Graphics.QML.DataModel.Internal.FFI.Types+) where++import Graphics.QML.DataModel.Internal.FFI.Types++import Control.Exception+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Ptr++-- Interface bindings.+foreign import ccall unsafe "registerHaskellModel" +  c_registerHaskellModel :: IO ()++foreign import ccall unsafe "registerHaskellModelDelegate"+  c_registerHaskellModelDelegate :: IO HmDelegateHandle++foreign import ccall unsafe "unregisterHaskellModelDelegate"+  c_unregisterHaskellModelDelegate :: HmDelegateHandle -> IO ()++-- Set delegate properties++foreign import ccall unsafe "setHaskellModelCallbacks"+  c_setHaskellModelCallbacks :: HmDelegateHandle -> Ptr HmCallbacks -> IO ()++foreign import ccall unsafe "addHaskellModelRole"+  c_addHaskellModelRole :: HmDelegateHandle -> CInt -> CString -> IO ()++addHaskellModelRole :: HmDelegateHandle -> Int -> String -> IO ()+addHaskellModelRole h i s = c_addHaskellModelRole h (fromIntegral i) =<< newCString s++-- QtVariant creation and destruction++foreign import ccall unsafe "newQtInt"+  c_newQtInt :: CInt -> IO QtVariant++foreign import ccall unsafe "newQtDouble"+  c_newQtDouble :: CDouble -> IO QtVariant++foreign import ccall unsafe "newQtText"+  c_newQtText :: CString -> IO QtVariant++newQtString :: String -> IO QtVariant+newQtString s = bracket (newCString s) free c_newQtText++foreign import ccall unsafe "newQtBool"+  c_newQtBool :: CInt -> IO QtVariant++foreign import ccall unsafe "newQtNull"+  c_newQtNull :: IO QtVariant++-- Function pointers for use within C.+foreign import ccall "wrapper"+  c_createRowCountCallback+    :: RowCountCallback -> IO (FunPtr RowCountCallback)++emptyRowCountCallback :: IO (FunPtr RowCountCallback)+emptyRowCountCallback = c_createRowCountCallback $ return 0++foreign import ccall "wrapper"+  c_createColumnCountCallback+    :: ColumnCountCallback -> IO (FunPtr ColumnCountCallback)++emptyColumnCountCallback :: IO (FunPtr RowCountCallback)+emptyColumnCountCallback = c_createColumnCountCallback $ return 0++foreign import ccall "wrapper" +  c_createDataCallback+    :: DataCallback -> IO (FunPtr DataCallback)++emptyDataCallback :: IO (FunPtr DataCallback)+emptyDataCallback = c_createDataCallback $ \_ _ -> c_newQtNull++foreign import ccall "wrapper"+  c_createHeaderDataCallback +    :: HeaderDataCallback -> IO (FunPtr HeaderDataCallback)++emptyHeaderDataCallback :: IO (FunPtr HeaderDataCallback)+emptyHeaderDataCallback = c_createHeaderDataCallback $ const c_newQtNull+
+ src/Graphics/QML/DataModel/Internal/FFI/Types.hsc view
@@ -0,0 +1,56 @@+{-# LANGUAGE ForeignFunctionInterface, TypeFamilies #-}++module Graphics.QML.DataModel.Internal.FFI.Types where++import Foreign.C.Types+import Foreign.Storable+import Foreign.Ptr+import Graphics.QML.Marshal++-- |Identifier of a HaskellModel delegate handle.+newtype HmDelegateHandle = HmDelegateHandle CInt+-- |Pointer to a QVariant type.+newtype QtVariant = QtVariant (Ptr CChar)+-- |Identifier of a column type.+newtype HmColumnType = HmColumnType CInt+  deriving (Eq, Show)++instance Marshal HmDelegateHandle where+  type MarshalMode HmDelegateHandle c d = ModeBidi c+  marshaller = bidiMarshaller +    (\i -> HmDelegateHandle (CInt i))+    (\(HmDelegateHandle (CInt i)) -> i)++-- |Used by QML to query the number of rows in a model.+type RowCountCallback    = IO CInt+-- |Used by QML to query the number of columns in a model.+type ColumnCountCallback = IO CInt+-- |Used by QML to obtain a row at the given index.+type DataCallback        = CInt -> CInt -> IO QtVariant+-- |Used by QML to obtain the name of the column at the given index.+type HeaderDataCallback  = CInt -> IO QtVariant++-- |C struct storing HaskellModel callbacks.+data HmCallbacks = HmCallbacks+  { rowCountCallback    :: FunPtr RowCountCallback+  , columnCountCallback :: FunPtr ColumnCountCallback+  , dataCallback        :: FunPtr DataCallback+  , headerDataCallback  :: FunPtr HeaderDataCallback+  }++#include "types.h"++instance Storable HmCallbacks where+  sizeOf     _ = #{size HaskellModelCallbacks}+  alignment  _ = alignment (undefined :: CInt)+  poke ptr hmc = do+         #{poke HaskellModelCallbacks, rowCountCb   } ptr $ rowCountCallback    hmc+         #{poke HaskellModelCallbacks, columnCountCb} ptr $ columnCountCallback hmc+         #{poke HaskellModelCallbacks, dataCb       } ptr $ dataCallback        hmc+         #{poke HaskellModelCallbacks, headerDataCb } ptr $ headerDataCallback  hmc+  peek ptr = HmCallbacks+         <$> (#peek HaskellModelCallbacks, rowCountCb   ) ptr+         <*> (#peek HaskellModelCallbacks, columnCountCb) ptr+         <*> (#peek HaskellModelCallbacks, dataCb       ) ptr+         <*> (#peek HaskellModelCallbacks, headerDataCb ) ptr+
+ src/Graphics/QML/DataModel/Internal/Generic.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE +    DeriveDataTypeable+  , DefaultSignatures+  , FlexibleContexts+  , FlexibleInstances+  , TypeOperators +  #-}++module Graphics.QML.DataModel.Internal.Generic +  ( module Graphics.QML.DataModel.Internal.Generic.Get+  , module Graphics.QML.DataModel.Internal.Generic.Set+  , module Graphics.QML.DataModel.Internal.Generic.Mock+  , module Graphics.QML.DataModel.Internal.Generic.Count+  ) where++import Graphics.QML.DataModel.Internal.Generic.Get+import Graphics.QML.DataModel.Internal.Generic.Set+import Graphics.QML.DataModel.Internal.Generic.Mock+import Graphics.QML.DataModel.Internal.Generic.Count+
+ src/Graphics/QML/DataModel/Internal/Generic/Count.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE +    DefaultSignatures+  , DeriveDataTypeable+  , FlexibleContexts+  , PolyKinds+  , ScopedTypeVariables+  , TypeOperators +  #-}++{-|+Module      : Graphics.QML.DataModel.Internal.Generic.Count+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++Count the number of columns in a data type.+-}++module Graphics.QML.DataModel.Internal.Generic.Count where++import Control.Exception+import Data.Typeable+import GHC.Generics++import Graphics.QML.DataModel.Internal.Generic.Mock++-- |Exception thrown when QML tries to acces a column that is not available. Shouldn't really happen.+data ColumnIndexException =+    ColumnIndexNegative Int        -- ^QML called for a negative column index.+  | ColumnIndexOutOfBounds Int Int -- ^QML called for a column index that is too high.+ deriving (Show, Typeable)++instance Exception ColumnIndexException++-- |A class of types that have a specific number of fields. Generic implementation is provided for all purely product types.+class CountFields t where+  countFields :: sing t -> Int+ +  default countFields :: (Mock t, Generic t, GCountFields (Rep t)) => sing t -> Int+  countFields _ = gCountFields $ from (mock :: t)++-- |Generic implementation of the 'CountFields' class.+class GCountFields f where+  gCountFields :: f a -> Int++-- |A container type has a single column.+instance GCountFields (K1 i c) where+  gCountFields (K1 _) = 1++-- |Meta information is skipped, and the recursion proceeds further down.+instance GCountFields f => GCountFields (M1 i t f) where+  gCountFields (M1 a) = gCountFields a++-- |A product type's number of columns is a sum of the terms' column numbers.+instance (GCountFields a, GCountFields b) => GCountFields (a :*: b) where+  gCountFields (a :*: b) = gCountFields a + gCountFields b+
+ src/Graphics/QML/DataModel/Internal/Generic/Get.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE +    DefaultSignatures+  , FlexibleContexts+  , FlexibleInstances+  , PolyKinds+  , TypeOperators+  #-}++{-|+Module      : Graphics.QML.DataModel.Internal.Generic.Get+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++Indexing data types by columns.+-}++module Graphics.QML.DataModel.Internal.Generic.Get where++import Graphics.QML.DataModel.Internal.FFI+import Graphics.QML.DataModel.Internal.Generic.Count++import Control.Exception+import Control.Monad+import Data.Text (Text, unpack)+import Foreign.C.Types+import GHC.Generics+import Numeric.Natural++-- |A class of types with columns that can be indexed by an integer. A generic implementation is provided for all single constructor types.+class QtTable t where+  getColumn :: Int -> t -> IO QtVariant++  default getColumn :: (Generic t, GQtTable (Rep t)) => Int -> t -> IO QtVariant+  getColumn ix = gGetColumn ix . from  ++-- |A generic implementation of 'QtTable'.+class GQtTable f  where+  gGetColumn :: Int -> f a -> IO QtVariant++-- |If only one value is available, it's returned regardless of the index.+instance QtField t => GQtTable (K1 i t) where+  gGetColumn _ (K1 v) = qtField v++-- |Meta information is skipped, and the recursion proceeds further down.+instance GQtTable f => GQtTable (M1 i t f) where+  gGetColumn ix (M1 a) = gGetColumn ix a++-- |One branch of a product type is chosen depending on the index.+instance (GCountFields a, GCountFields b, GQtTable a, GQtTable b) => GQtTable (a :*: b) where+  gGetColumn ix (a :*: b) = do+       when (ix < 0)          . throwIO $ ColumnIndexNegative    ix+       when (ix >= (na + nb)) . throwIO $ ColumnIndexOutOfBounds ix (na + nb)+       if ix < na +          then gGetColumn  ix       a+          else gGetColumn (ix - na) b+     where na = gCountFields a+           nb = gCountFields b++-- |A class of types with columns that can be cast to a 'QtVariant'.+class QtField t where+  qtField :: t -> IO QtVariant++instance QtField Int where+  qtField = c_newQtInt . CInt . fromIntegral++instance QtField Double  where+  qtField = c_newQtDouble . CDouble++instance QtField String where+  qtField = newQtString++instance QtField Text where+  qtField = newQtString . unpack ++instance QtField Bool where+  qtField v = c_newQtBool $ fromIntegral b+     where b :: Int+           b = if v then 1 else 0 ++-- |Indegers are marshalled through QT strings rather than ints.+instance QtField Integer where+  qtField = newQtString . show++-- |Naturals are marshalled through QT strings rather than ints.+instance QtField Natural where+  qtField = newQtString . show++-- |'Nothing' is marshalled as QT null.+instance QtField t => QtField (Maybe t) where+  qtField Nothing  = c_newQtNull+  qtField (Just t) = qtField t++
+ src/Graphics/QML/DataModel/Internal/Generic/Mock.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE +    DefaultSignatures+  , FlexibleContexts+  , PolyKinds+  , TypeOperators +  #-}++{-|+Module      : Graphics.QML.DataModel.Internal.Generic.Mock+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental+-}++module Graphics.QML.DataModel.Internal.Generic.Mock where++import GHC.Generics +{-|+A class that constructs a mock object, with all fields set to 'undefined',+for use with generic implementations that don't actually use the supplied data.+Only data types with a single constuctor can have an unambiguous mock object.+-}+class Mock t where+  -- |Construct a mock object of a data type with a single constructor, with 'undefined' fields.+  mock :: t++  default mock :: (Generic t, GMock (Rep t)) => t+  mock = to gMock+ +class GMock f where+  -- |Generic version of 'mock'.+  gMock :: f a++instance GMock (K1 i c) where+  gMock = K1 undefined++instance GMock f => GMock (M1 i t f) where+  gMock = M1 gMock++instance (GMock a, GMock b) => GMock (a :*: b) where+  gMock = gMock :*: gMock +
+ src/Graphics/QML/DataModel/Internal/Generic/Set.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE+    DefaultSignatures+  , FlexibleContexts+  , FlexibleInstances+  , PolyKinds+  , ScopedTypeVariables+  , TypeOperators+  #-}++{-|+Module      : Graphics.QML.DataModel.Internal.Generic.Set+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++Setup the column names of a HaskellModel.+-}++module Graphics.QML.DataModel.Internal.Generic.Set where++import Graphics.QML.DataModel.Internal.FFI+import Graphics.QML.DataModel.Internal.Generic.Count+import Graphics.QML.DataModel.Internal.Generic.Mock++import GHC.Generics++-- |A class of types that can provide a template to setup the QT HaskellModel. A generic implementation is provided for all single constructor types.+class SetupColumns t where+  setupColumns :: HmDelegateHandle -> sing t -> IO ()++  default setupColumns +    :: ( Mock t+       , Generic t+       , GSetupColumns (Rep t)+       ) +    => HmDelegateHandle +    -> sing t +    -> IO ()+  setupColumns d _ = gSetupColumns d $ from (mock :: t)+  +-- |A generic implementation for 'SetupColumns'.+class GSetupColumns f where+  gSetupColumns :: HmDelegateHandle -> f a -> IO ()++-- |A helper class for the generic implementation for 'SetupColumns', starts its work at a particular index.+class GSetupColumnIx f where+  gSetupColumnIx :: HmDelegateHandle -> Int -> f a -> IO ()++-- |Meta information for a whole datatype is skipped, and the recursion proceeds further down.+instance GSetupColumns f => GSetupColumns (M1 D t f) where+  gSetupColumns h (M1 t) = gSetupColumns h t++-- |Meta information for a constructor is skipped, and 'SetupColumnIx' is used starting at index 0.+instance GSetupColumnIx f => GSetupColumns (M1 C t f) where+  gSetupColumns h (M1 t) = gSetupColumnIx h 0 t++-- |Setups both terms of the product.+instance ( GCountFields a+         , GCountFields b+         , GSetupColumnIx a+         , GSetupColumnIx b+         ) => GSetupColumnIx (a :*: b) where+  gSetupColumnIx h ix (a :*: b) = do+     gSetupColumnIx h  ix                   a+     gSetupColumnIx h (ix + gCountFields a) b++-- |A model role name is added accoring to the record selector's name.+instance Selector t => GSetupColumnIx (M1 S t f) where+  gSetupColumnIx h ix t = addHaskellModelRole h ix $ selName t+
+ src/Graphics/QML/DataModel/Internal/Types.hs view
@@ -0,0 +1,22 @@+module Graphics.QML.DataModel.Internal.Types where++import qualified Graphics.QML.DataModel.Internal.FFI.Types as FFI++import Control.Concurrent.MVar+import Foreign.Ptr++-- |A data model handle.+data DataModel a = DataModel+  { callbacks :: MVar (Ptr FFI.HmCallbacks) -- ^Pointer to a C structure storing the callbacks.+  , delegate  :: FFI.HmDelegateHandle       -- ^Identifier of the handle.+  }++-- |Used by QML to query the number of rows in a model.+type RowCountCallback    = IO Int+-- |Used by QML to query the number of columns in a model.+type ColumnCountCallback = IO Int+-- |Used by QML to obtain a row at the given index.+type DataCallback a      = Int -> IO a+-- |Used by QML to obtain the name of the column at the given index.+type HeaderDataCallback  = Int -> IO String+
+ src/Graphics/QML/DataModel/TH.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}++module Graphics.QML.DataModel.TH + ( dataModelInstances+ , module Graphics.QML.DataModel.Generic+ ) where++import Language.Haskell.TH+import Graphics.QML.DataModel.Generic++dataModelInstances :: Name -> DecsQ+{-^ +A shorthand to declare all instances necessary for setting up the HaskellModel.++@dataModelInstances T@ is equivalent to++@+ instance QtTable      T+ instance Mock         T+ instance CountFields  T+ instance SetupColumns T+@++-}+dataModelInstances name = +   [d| instance QtTable      $t; +       instance Mock         $t;+       instance CountFields  $t;+       instance SetupColumns $t;+   |] + where t = conT name+
+ src/Graphics/QML/DataModel/Tutorial.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Graphics.QML.DataModel.Tutorial +  ( -- * Haskell side+    -- $hsk++    -- * QML side+    -- $qml+  ) where++import Graphics.QML.DataModel+import Graphics.QML.DataModel.TH+import Graphics.QML+import GHC.Generics++{- $hsk+Any data type with a single constructor and marshallable fields can be used in a QML data model. For example:++@+  data Row = Row {foo :: Int, bar :: String, baz :: Double}+    deriving Generic+@++To use the data type in a model, first you need to declare the necessary instances.+All the necessary classes have default implementations using 'Generic'.+To further automate the process, there's a Template Haskell macro that declares them all:++@ + dataModelInstances Row+@ ++If you don't want to use TH, you can declare them manually:++@+ instance QtTable      Row+ instance Mock         Row+ instance CountFields  Row+ instance SetupColumns Row+@++Finally, in your 'main' function, register the data model as a QML type, set up the delegate and its callbacks, and provide a way for QML to access it.++@+setTVarCallbacks +  :: QtTable a +  => DataModel a +  -> TVar [a]+  -> IO ()+setTVarCallbacks model tv = do+  setRowCountCallback model $      length <$> readTVarIO mtv+  setDataCallback     model $ \i -> (!!i) <$> readTVarIO mtv++main = do+    registerHaskellModel   ++    storage <- newTVarIO [Row 1 "a" 3.0, Row 2 "b" 4.2]+    model <- setupDataModel+    setTVarCallbacks model storage++    toplevel'class <- newClass [ defPropertyConst' "haskellModelDelegate" . return $ delegate model ]+    toplevel'obj <- newObject toplevel'class ()++    runEngineLoop defaultEngineConfig +      { initialDocument = "path//to//your//main.qml"+      , contextObject = Just $ anyObjRef toplevel'obj+      }+@++-}+++{- $qml+Using the model in QML is simple as that:++@+  HaskellModel {+    id: haskellModel;+    delegate: haskellModelDelegate;+  }++  TableView {+    id: hsView;+    model: haskellModel;++    TableViewColumn {+      title: \"A\";+      role: "baz";+    }++    TableViewColumn {+      title: \"B\";+      role: "foo";+    }+  }+@++Record fields become roles, and you can use them in any order any with any names you like.+Views other than TableView can be used too, of course.++-}+