haskades (empty) → 0.1
raw patch · 7 files changed
+1024/−0 lines, 7 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, errors, haskell-src, text, text-format
Files
- COPYING +13/−0
- MustacheTemplates.hs +619/−0
- README +19/−0
- Records.hs +49/−0
- Setup.hs +3/−0
- haskades.cabal +58/−0
- haskades.hs +263/−0
+ COPYING view
@@ -0,0 +1,13 @@+Copyright © 2012, Stephen Paul Weber <singpolyma.net>++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ MustacheTemplates.hs view
@@ -0,0 +1,619 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-matches #-}+module MustacheTemplates where++import Data.Monoid+import Data.Text.Buildable (build)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TL+import Records++haskadesBindinghs escapeFunction ctx@(Template {modul=modul, slots=slots, signalTypes=signalTypes, signals=signals}) = mconcat [+ {-# LINE 1 "HaskadesBinding.hs.mustache" #-}+ build "{",+ {-# LINE 1 "HaskadesBinding.hs.mustache" #-}+ build "-# LANGUAGE ForeignFunctionInterface #-}\n",+ {-# LINE 2 "HaskadesBinding.hs.mustache" #-}+ build "{",+ {-# LINE 2 "HaskadesBinding.hs.mustache" #-}+ build "-# OPTIONS_GHC -fno-warn-unused-imports #-}\nmodule HaskadesBinding (haskadesRun, emit) where\n\nimport Foreign.C.Types\nimport Foreign.C.String\nimport Foreign.Ptr\nimport System.Exit (exitWith, ExitCode(ExitFailure))\nimport Control.Monad (when, ap, join)\nimport Control.Monad.IO.Class (MonadIO, liftIO)\nimport Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Text\nimport qualified Data.Text.Lazy as LText\nimport qualified Data.Text.Lazy.Encoding as LText\nimport qualified Data.ByteString as ByteString\n\nimport ",+ {-# LINE 18 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build modul,+ {-# LINE 18 "HaskadesBinding.hs.mustache" #-}+ build "\n\nforeign import ccall safe \"haskades_run.cpp haskades_run\"\n\tc_haskades_run ::\n\tCString -> ",+ {-# LINE 22 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (slots0 escapeFunction) slots,+ {-# LINE 23 "HaskadesBinding.hs.mustache" #-}+ build "\tIO CInt\n\nforeign import ccall unsafe \"start.cpp emit_CustomSignalEvent\"\n\tc_emit_CustomSignalEvent ::\n\tCInt -> ",+ {-# LINE 27 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (signalTypes2 escapeFunction) signalTypes,+ {-# LINE 28 "HaskadesBinding.hs.mustache" #-}+ build "\tIO ()\n\nemit :: (MonadIO m) => Signal -> m ()\n",+ {-# LINE 31 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (signals3 escapeFunction) signals,+ {-# LINE 37 "HaskadesBinding.hs.mustache" #-}+ build "\n-- Function pointer wrappers\n",+ {-# LINE 39 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (slots5 escapeFunction) slots,+ {-# LINE 42 "HaskadesBinding.hs.mustache" #-}+ build "\nhaskadesRun :: (MonadIO m) => String -> Slots -> m ()\nhaskadesRun qmlPath (Slots ",+ {-# LINE 44 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (slots8 escapeFunction) slots,+ {-# LINE 44 "HaskadesBinding.hs.mustache" #-}+ build ") = liftIO $ do\n",+ {-# LINE 45 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (slots9 escapeFunction) slots,+ {-# LINE 48 "HaskadesBinding.hs.mustache" #-}+ build "\n\tcode <- ByteString.useAsCString (Text.encodeUtf8 $ Text.pack qmlPath) (\\qmlPath ->\n\t\t\tc_haskades_run qmlPath ",+ {-# LINE 50 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (slots14 escapeFunction) slots,+ {-# LINE 51 "HaskadesBinding.hs.mustache" #-}+ build "\t\t)\n\n",+ {-# LINE 53 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (slots15 escapeFunction) slots,+ {-# LINE 56 "HaskadesBinding.hs.mustache" #-}+ build "\n\twhen (code /= 0) (exitWith $ ExitFailure $ fromIntegral code)\n\treturn ()\n"+ ]+ where+ slots0 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 22 "HaskadesBinding.hs.mustache" #-}+ build "FunPtr (",+ {-# LINE 22 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (args1 escapeFunction) args,+ {-# LINE 22 "HaskadesBinding.hs.mustache" #-}+ build " ",+ {-# LINE 22 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build crtype,+ {-# LINE 22 "HaskadesBinding.hs.mustache" #-}+ build ") -> "+ ]+ where+ args1 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 22 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build ctype,+ {-# LINE 22 "HaskadesBinding.hs.mustache" #-}+ build " -> "+ ]+ signalTypes2 escapeFunction ctx@(SignalType {csigtype=csigtype, qtsigtype=qtsigtype, qtwrapsig=qtwrapsig, lowcsigtype=lowcsigtype, sigtypename=sigtypename}) = mconcat [+ {-# LINE 27 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build csigtype,+ {-# LINE 27 "HaskadesBinding.hs.mustache" #-}+ build " -> "+ ]+ signals3 escapeFunction ctx@(Signal {signame=signame, sigargs=sigargs, sigevent=sigevent, sigcwrap=sigcwrap}) = mconcat [+ {-# LINE 32 "HaskadesBinding.hs.mustache" #-}+ build "emit (",+ {-# LINE 32 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build signame,+ {-# LINE 32 "HaskadesBinding.hs.mustache" #-}+ build " ",+ {-# LINE 32 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (sigargs4 escapeFunction) sigargs,+ {-# LINE 32 "HaskadesBinding.hs.mustache" #-}+ build ") = liftIO (\n\t\t(",+ {-# LINE 33 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigcwrap,+ {-# LINE 33 "HaskadesBinding.hs.mustache" #-}+ build ")\n\t\t(c_emit_CustomSignalEvent ",+ {-# LINE 34 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigevent,+ {-# LINE 34 "HaskadesBinding.hs.mustache" #-}+ build ")\n\t)\n"+ ]+ where+ sigargs4 escapeFunction ctx@(SignalArg {sigargfirst=sigargfirst, siganame=siganame, qtsigargtype=qtsigargtype, sigargsigtypename=sigargsigtypename}) = mconcat [+ {-# LINE 32 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build siganame,+ {-# LINE 32 "HaskadesBinding.hs.mustache" #-}+ build " "+ ]+ slots5 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build "foreign import ccall \"wrapper\" wrap_",+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build " :: (",+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (args6 escapeFunction) args,+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build " ",+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build crtype,+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build ") -> IO (FunPtr (",+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (args7 escapeFunction) args,+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build " ",+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build crtype,+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build "))\n"+ ]+ where+ args6 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build ctype,+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build " -> "+ ]+ args7 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build ctype,+ {-# LINE 40 "HaskadesBinding.hs.mustache" #-}+ build " -> "+ ]+ slots8 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 44 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 44 "HaskadesBinding.hs.mustache" #-}+ build " "+ ]+ slots9 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build "\t",+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build "Ptr <- wrap_",+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build " (",+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ if mempty /= (Any hasArgs) then hasArgs10 escapeFunction ctx else mempty,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (args11 escapeFunction) args,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ if mempty /= (Any hasArgs) then hasArgs12 escapeFunction ctx else mempty,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build "(join ((return ",+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build monadic,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build ") ",+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ mconcat $ map (args13 escapeFunction) args,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build ")) >>= ",+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build crwrap,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build ")\n"+ ]+ where+ hasArgs10 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build "\\"+ ]+ args11 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build aname,+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build " "+ ]+ hasArgs12 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build "-> "+ ]+ args13 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build " `ap` ",+ {-# LINE 46 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build cwrap+ ]+ slots14 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 50 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 50 "HaskadesBinding.hs.mustache" #-}+ build "Ptr "+ ]+ slots15 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 54 "HaskadesBinding.hs.mustache" #-}+ build "\tfreeHaskellFunPtr ",+ {-# LINE 54 "HaskadesBinding.hs.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 54 "HaskadesBinding.hs.mustache" #-}+ build "Ptr\n"+ ]++haskades_runcpp escapeFunction ctx@(Template {modul=modul, slots=slots, signalTypes=signalTypes, signals=signals}) = mconcat [+ {-# LINE 1 "haskades_run.cpp.mustache" #-}+ build "#include <QtDebug>\n#include <QLocale>\n#include <QTranslator>\n#include <bb/cascades/Application>\n#include <bb/cascades/QmlDocument>\n#include <bb/cascades/AbstractPane>\n\n#ifdef USE_NOTIFICATIONS\n#include <bb/platform/Notification>\n#include <bb/platform/NotificationDialog>\n#endif\n\nQEvent::Type customSignalEventType;\n",+ {-# LINE 14 "haskades_run.cpp.mustache" #-}+ mconcat $ map (signals0 escapeFunction) signals,+ {-# LINE 17 "haskades_run.cpp.mustache" #-}+ build "\nclass CustomSignalEvent : public QEvent ",+ {-# LINE 18 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 18 "haskades_run.cpp.mustache" #-}+ build "\n\npublic:\n\tCustomSignalEvent(int signalEvent",+ {-# LINE 21 "haskades_run.cpp.mustache" #-}+ mconcat $ map (signalTypes1 escapeFunction) signalTypes,+ {-# LINE 21 "haskades_run.cpp.mustache" #-}+ build ") : QEvent(customSignalEventType) ",+ {-# LINE 21 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 21 "haskades_run.cpp.mustache" #-}+ build "\n\t\tthis->signalEvent = signalEvent;\n",+ {-# LINE 23 "haskades_run.cpp.mustache" #-}+ mconcat $ map (signalTypes2 escapeFunction) signalTypes,+ {-# LINE 26 "haskades_run.cpp.mustache" #-}+ build "\t}\n\n\tint signalEvent;\n",+ {-# LINE 29 "haskades_run.cpp.mustache" #-}+ mconcat $ map (signalTypes3 escapeFunction) signalTypes,+ {-# LINE 32 "haskades_run.cpp.mustache" #-}+ build "};\n\nclass AppWrapper: public QObject ",+ {-# LINE 34 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 34 "haskades_run.cpp.mustache" #-}+ build "\nQ_OBJECT\n\npublic:\n\t// This is our constructor that sets up the recipe.\n\tAppWrapper(QString qml_path",+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ mconcat $ map (slots4 escapeFunction) slots,+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build ") :\n\tqmlPath(qml_path)",+ {-# LINE 40 "haskades_run.cpp.mustache" #-}+ mconcat $ map (slots7 escapeFunction) slots,+ {-# LINE 42 "haskades_run.cpp.mustache" #-}+ build "\t",+ {-# LINE 42 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 42 "haskades_run.cpp.mustache" #-}+ build "\n#ifdef USE_NOTIFICATIONS\nqmlRegisterType<bb::platform::Notification>(\"bb.platform\", 1, 0, \"Notification\");\nqmlRegisterType<bb::platform::NotificationDialog>(\"bb.platform\", 1, 0, \"NotificationDialog\");\n#endif\n\t}\n\n\tvirtual void ready() ",+ {-# LINE 49 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 49 "haskades_run.cpp.mustache" #-}+ build "\n\t\t// Obtain a QMLDocument and load it into the qml variable, using build patterns.\n\t\tbb::cascades::QmlDocument *qml = bb::cascades::QmlDocument::create(this->qmlPath);\n\n\t\t// If the QML document is valid, we process it.\n\t\tif(!qml->hasErrors()) ",+ {-# LINE 54 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 54 "haskades_run.cpp.mustache" #-}+ build "\n\t\t\tqml->setContextProperty(\"app\", this);\n\n\t\t\t// Create the application root from QMLDocument\n\t\t\tbb::cascades::AbstractPane *appPage = qml->createRootObject<bb::cascades::AbstractPane>();\n\n\t\t\tif (appPage) ",+ {-# LINE 60 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 60 "haskades_run.cpp.mustache" #-}+ build "\n\t\t\t\t// Set the main scene for the application to the Page.\n\t\t\t\tbb::cascades::Application::instance()->setScene(appPage);\n\t\t\t}\n\t\t} else ",+ {-# LINE 64 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 64 "haskades_run.cpp.mustache" #-}+ build "\n\t\t\tqCritical() << qml->errors();\n\t\t}\n\t}\n\n\tvirtual bool event(QEvent *e) ",+ {-# LINE 69 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 69 "haskades_run.cpp.mustache" #-}+ build "\n\t\tif(e->type() == customSignalEventType) ",+ {-# LINE 70 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 70 "haskades_run.cpp.mustache" #-}+ build "\n\t\t\tCustomSignalEvent *ev = (CustomSignalEvent*)e;\n\t\t\tswitch(ev->signalEvent) ",+ {-# LINE 72 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 72 "haskades_run.cpp.mustache" #-}+ build "\n",+ {-# LINE 73 "haskades_run.cpp.mustache" #-}+ mconcat $ map (signals8 escapeFunction) signals,+ {-# LINE 79 "haskades_run.cpp.mustache" #-}+ build "\t\t\t}\n\t\t\treturn false;\n\t\t} else ",+ {-# LINE 81 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 81 "haskades_run.cpp.mustache" #-}+ build "\n\t\t\treturn QObject::event(e);\n\t\t}\n\t}\n\npublic slots:\n",+ {-# LINE 87 "haskades_run.cpp.mustache" #-}+ mconcat $ map (slots11 escapeFunction) slots,+ {-# LINE 92 "haskades_run.cpp.mustache" #-}+ build "\nsignals:\n",+ {-# LINE 94 "haskades_run.cpp.mustache" #-}+ mconcat $ map (signals16 escapeFunction) signals,+ {-# LINE 97 "haskades_run.cpp.mustache" #-}+ build "\nprotected:\n\tQString qmlPath;\n",+ {-# LINE 100 "haskades_run.cpp.mustache" #-}+ mconcat $ map (slots19 escapeFunction) slots,+ {-# LINE 103 "haskades_run.cpp.mustache" #-}+ build "};\n\nextern \"C\" ",+ {-# LINE 105 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 105 "haskades_run.cpp.mustache" #-}+ build "\n\nQObject *mainAppGlobal;\n\nvoid emit_CustomSignalEvent(int signalEvent",+ {-# LINE 109 "haskades_run.cpp.mustache" #-}+ mconcat $ map (signalTypes22 escapeFunction) signalTypes,+ {-# LINE 109 "haskades_run.cpp.mustache" #-}+ build ") ",+ {-# LINE 109 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 109 "haskades_run.cpp.mustache" #-}+ build "\n\tQEvent *e = (QEvent *)new CustomSignalEvent(signalEvent",+ {-# LINE 110 "haskades_run.cpp.mustache" #-}+ mconcat $ map (signalTypes23 escapeFunction) signalTypes,+ {-# LINE 110 "haskades_run.cpp.mustache" #-}+ build ");\n\tQCoreApplication::postEvent(mainAppGlobal, e);\n}\n\nint haskades_run(char *qml_path",+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ mconcat $ map (slots24 escapeFunction) slots,+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build ") ",+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build "\n\tint argc = 0;\n\tchar *argv[] = ",+ {-# LINE 116 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 116 "haskades_run.cpp.mustache" #-}+ build " NULL };\n\t// Instantiate the main application constructor.\n\tbb::cascades::Application app(argc, argv);\n\n\t// Set up the translator.\n\tQTranslator translator;\n\tQString locale_string = QLocale().name();\n\tQString filename = QString(\"sample_%1\").arg(locale_string); // TODO\n\tif (translator.load(filename, \"app/native/qm\")) ",+ {-# LINE 124 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 124 "haskades_run.cpp.mustache" #-}+ build "\n\t\tapp.installTranslator(&translator);\n\t}\n\n\tcustomSignalEventType = (QEvent::Type)QEvent::registerEventType();\n\n\t// Initialize our application.\n\tAppWrapper mainApp(QString::fromUtf8(qml_path)",+ {-# LINE 131 "haskades_run.cpp.mustache" #-}+ mconcat $ map (slots27 escapeFunction) slots,+ {-# LINE 131 "haskades_run.cpp.mustache" #-}+ build ");\n\tmainAppGlobal = (QObject*)&mainApp;\n\tmainApp.ready();\n\n\t// We complete the transaction started in the main application constructor and start the\n\t// client event loop here. When loop is exited the Application deletes the scene which\n\t// deletes all its children.\n\treturn bb::cascades::Application::exec();\n}\n\n}\n\n// Tell MOC to run on this file\n#include \"haskades_run.moc\"\n"+ ]+ where+ signals0 escapeFunction ctx@(Signal {signame=signame, sigargs=sigargs, sigevent=sigevent, sigcwrap=sigcwrap}) = mconcat [+ {-# LINE 15 "haskades_run.cpp.mustache" #-}+ build "#define CUSTOM_SIGNAL_",+ {-# LINE 15 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build signame,+ {-# LINE 15 "haskades_run.cpp.mustache" #-}+ build " ",+ {-# LINE 15 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigevent,+ {-# LINE 15 "haskades_run.cpp.mustache" #-}+ build "\n"+ ]+ signalTypes1 escapeFunction ctx@(SignalType {csigtype=csigtype, qtsigtype=qtsigtype, qtwrapsig=qtwrapsig, lowcsigtype=lowcsigtype, sigtypename=sigtypename}) = mconcat [+ {-# LINE 21 "haskades_run.cpp.mustache" #-}+ build ", ",+ {-# LINE 21 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build qtsigtype,+ {-# LINE 21 "haskades_run.cpp.mustache" #-}+ build " ",+ {-# LINE 21 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigtypename+ ]+ signalTypes2 escapeFunction ctx@(SignalType {csigtype=csigtype, qtsigtype=qtsigtype, qtwrapsig=qtwrapsig, lowcsigtype=lowcsigtype, sigtypename=sigtypename}) = mconcat [+ {-# LINE 24 "haskades_run.cpp.mustache" #-}+ build "\t\tthis->",+ {-# LINE 24 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigtypename,+ {-# LINE 24 "haskades_run.cpp.mustache" #-}+ build " = ",+ {-# LINE 24 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigtypename,+ {-# LINE 24 "haskades_run.cpp.mustache" #-}+ build ";\n"+ ]+ signalTypes3 escapeFunction ctx@(SignalType {csigtype=csigtype, qtsigtype=qtsigtype, qtwrapsig=qtwrapsig, lowcsigtype=lowcsigtype, sigtypename=sigtypename}) = mconcat [+ {-# LINE 30 "haskades_run.cpp.mustache" #-}+ build "\t",+ {-# LINE 30 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build qtsigtype,+ {-# LINE 30 "haskades_run.cpp.mustache" #-}+ build " ",+ {-# LINE 30 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigtypename,+ {-# LINE 30 "haskades_run.cpp.mustache" #-}+ build ";\n"+ ]+ slots4 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build ", void (*_",+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build ")(",+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ mconcat $ map (args5 escapeFunction) args,+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build ")"+ ]+ where+ args5 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ if mempty == (Any firstarg) then firstarg6 escapeFunction ctx else mempty,+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build lowctype,+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build " ",+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build aname+ ]+ where+ firstarg6 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 39 "haskades_run.cpp.mustache" #-}+ build ", "+ ]+ slots7 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 40 "haskades_run.cpp.mustache" #-}+ build ",\n\t_",+ {-# LINE 41 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 41 "haskades_run.cpp.mustache" #-}+ build "(_",+ {-# LINE 41 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 41 "haskades_run.cpp.mustache" #-}+ build ")"+ ]+ signals8 escapeFunction ctx@(Signal {signame=signame, sigargs=sigargs, sigevent=sigevent, sigcwrap=sigcwrap}) = mconcat [+ {-# LINE 74 "haskades_run.cpp.mustache" #-}+ build "\t\t\t\tcase CUSTOM_SIGNAL_",+ {-# LINE 74 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build signame,+ {-# LINE 74 "haskades_run.cpp.mustache" #-}+ build ":\n\t\t\t\t\temit ",+ {-# LINE 75 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build signame,+ {-# LINE 75 "haskades_run.cpp.mustache" #-}+ build "(",+ {-# LINE 75 "haskades_run.cpp.mustache" #-}+ mconcat $ map (sigargs9 escapeFunction) sigargs,+ {-# LINE 75 "haskades_run.cpp.mustache" #-}+ build ");\n\t\t\t\t\treturn true;\n\t\t\t\t\tbreak;\n"+ ]+ where+ sigargs9 escapeFunction ctx@(SignalArg {sigargfirst=sigargfirst, siganame=siganame, qtsigargtype=qtsigargtype, sigargsigtypename=sigargsigtypename}) = mconcat [+ {-# LINE 75 "haskades_run.cpp.mustache" #-}+ if mempty == (Any sigargfirst) then sigargfirst10 escapeFunction ctx else mempty,+ {-# LINE 75 "haskades_run.cpp.mustache" #-}+ build "ev->",+ {-# LINE 75 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigargsigtypename+ ]+ where+ sigargfirst10 escapeFunction ctx@(SignalArg {sigargfirst=sigargfirst, siganame=siganame, qtsigargtype=qtsigargtype, sigargsigtypename=sigargsigtypename}) = mconcat [+ {-# LINE 75 "haskades_run.cpp.mustache" #-}+ build ", "+ ]+ slots11 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build "\tQ_INVOKABLE void ",+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build "(",+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ mconcat $ map (args12 escapeFunction) args,+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build ") ",+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build "{",+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build "\n\t\t_",+ {-# LINE 89 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 89 "haskades_run.cpp.mustache" #-}+ build "(",+ {-# LINE 89 "haskades_run.cpp.mustache" #-}+ mconcat $ map (args14 escapeFunction) args,+ {-# LINE 89 "haskades_run.cpp.mustache" #-}+ build ");\n\t}\n"+ ]+ where+ args12 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ if mempty == (Any firstarg) then firstarg13 escapeFunction ctx else mempty,+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build qttype,+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build " ",+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build aname+ ]+ where+ firstarg13 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 88 "haskades_run.cpp.mustache" #-}+ build ", "+ ]+ args14 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 89 "haskades_run.cpp.mustache" #-}+ if mempty == (Any firstarg) then firstarg15 escapeFunction ctx else mempty,+ {-# LINE 89 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build qtunwrap+ ]+ where+ firstarg15 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 89 "haskades_run.cpp.mustache" #-}+ build ", "+ ]+ signals16 escapeFunction ctx@(Signal {signame=signame, sigargs=sigargs, sigevent=sigevent, sigcwrap=sigcwrap}) = mconcat [+ {-# LINE 95 "haskades_run.cpp.mustache" #-}+ build "\tvoid ",+ {-# LINE 95 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build signame,+ {-# LINE 95 "haskades_run.cpp.mustache" #-}+ build "(",+ {-# LINE 95 "haskades_run.cpp.mustache" #-}+ mconcat $ map (sigargs17 escapeFunction) sigargs,+ {-# LINE 95 "haskades_run.cpp.mustache" #-}+ build ");\n"+ ]+ where+ sigargs17 escapeFunction ctx@(SignalArg {sigargfirst=sigargfirst, siganame=siganame, qtsigargtype=qtsigargtype, sigargsigtypename=sigargsigtypename}) = mconcat [+ {-# LINE 95 "haskades_run.cpp.mustache" #-}+ if mempty == (Any sigargfirst) then sigargfirst18 escapeFunction ctx else mempty,+ {-# LINE 95 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build qtsigargtype+ ]+ where+ sigargfirst18 escapeFunction ctx@(SignalArg {sigargfirst=sigargfirst, siganame=siganame, qtsigargtype=qtsigargtype, sigargsigtypename=sigargsigtypename}) = mconcat [+ {-# LINE 95 "haskades_run.cpp.mustache" #-}+ build ", "+ ]+ slots19 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ build "\tvoid (*_",+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ build ")(",+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ mconcat $ map (args20 escapeFunction) args,+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ build ");\n"+ ]+ where+ args20 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ if mempty == (Any firstarg) then firstarg21 escapeFunction ctx else mempty,+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build lowctype,+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ build " ",+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build aname+ ]+ where+ firstarg21 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 101 "haskades_run.cpp.mustache" #-}+ build ", "+ ]+ signalTypes22 escapeFunction ctx@(SignalType {csigtype=csigtype, qtsigtype=qtsigtype, qtwrapsig=qtwrapsig, lowcsigtype=lowcsigtype, sigtypename=sigtypename}) = mconcat [+ {-# LINE 109 "haskades_run.cpp.mustache" #-}+ build ", ",+ {-# LINE 109 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build lowcsigtype,+ {-# LINE 109 "haskades_run.cpp.mustache" #-}+ build " ",+ {-# LINE 109 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build sigtypename+ ]+ signalTypes23 escapeFunction ctx@(SignalType {csigtype=csigtype, qtsigtype=qtsigtype, qtwrapsig=qtwrapsig, lowcsigtype=lowcsigtype, sigtypename=sigtypename}) = mconcat [+ {-# LINE 110 "haskades_run.cpp.mustache" #-}+ build ", ",+ {-# LINE 110 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build qtwrapsig+ ]+ slots24 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build ", void (*_",+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name,+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build ")(",+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ mconcat $ map (args25 escapeFunction) args,+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build ")"+ ]+ where+ args25 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ if mempty == (Any firstarg) then firstarg26 escapeFunction ctx else mempty,+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build lowctype,+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build " ",+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build aname+ ]+ where+ firstarg26 escapeFunction ctx@(SlotArg {firstarg=firstarg, aname=aname, ctype=ctype, lowctype=lowctype, qttype=qttype, cwrap=cwrap, qtunwrap=qtunwrap}) = mconcat [+ {-# LINE 114 "haskades_run.cpp.mustache" #-}+ build ", "+ ]+ slots27 escapeFunction ctx@(Slot {name=name, monadic=monadic, args=args, hasArgs=hasArgs, crtype=crtype, crwrap=crwrap}) = mconcat [+ {-# LINE 131 "haskades_run.cpp.mustache" #-}+ build ", _",+ {-# LINE 131 "haskades_run.cpp.mustache" #-}+ build $ escapeFunction $ TL.unpack $ TL.toLazyText $ build name+ ]++
+ README view
@@ -0,0 +1,19 @@+Autogeneration of bindings for creating BlackBerry Cascades apps+with Haskell back ends.++Run as:++> ./haskades HaskadesBinding.hs haskades_run.cpp < Types.hs++Where Types.hs is a Haskell file containing a record type declaration+named 'Slots' and a sum type declaration named 'Signals' which fully+specifies the communication possible between the UI layer (which you+write in QML) and the Haskell backend. QML code can access these+signals and slots on the 'app' context object. Haskell code can emit+signals by using the 'emit' function exported from the generated+HaskadesBinding. The 'emit' call is threadsafe.++Text, Lazy Text, and String all end up as QString so that QML can+work with them properly, and vice-versa. UTCTime becomes QDateTime.+Int, Double, and () are passed through fairly directly. Other types+may have support added as there is need.
+ Records.hs view
@@ -0,0 +1,49 @@+module Records where++data Template = Template {+ modul :: String,+ slots :: [Slot],+ signalTypes :: [SignalType],+ signals :: [Signal]+} deriving (Show)++data Slot = Slot {+ name :: String,+ monadic :: String,+ args :: [SlotArg],+ hasArgs :: Bool,+ crtype :: String,+ crwrap :: String+} deriving (Show)++data SlotArg = SlotArg {+ firstarg :: Bool,+ aname :: String,+ ctype :: String,+ lowctype :: String,+ qttype :: String,+ cwrap :: String,+ qtunwrap :: String+} deriving (Show)++data SignalType = SignalType {+ csigtype :: String,+ qtsigtype :: String,+ qtwrapsig :: String,+ lowcsigtype :: String,+ sigtypename :: String+} deriving (Show)++data Signal = Signal {+ signame :: String,+ sigargs :: [SignalArg],+ sigevent :: Integer,+ sigcwrap :: String+} deriving (Show)++data SignalArg = SignalArg {+ sigargfirst :: Bool,+ siganame :: String,+ qtsigargtype :: String,+ sigargsigtypename :: String+} deriving (Show)
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ haskades.cabal view
@@ -0,0 +1,58 @@+name: haskades+version: 0.1+cabal-version: >= 1.8+license: OtherLicense+license-file: COPYING+category: Utility+copyright: © 2012 Stephen Paul Weber+author: Stephen Paul Weber <singpolyma@singpolyma.net>+maintainer: Stephen Paul Weber <singpolyma@singpolyma.net>+stability: experimental+tested-with: GHC == 7.0.3+synopsis: Utility to generate bindings for BlackBerry Cascades+homepage: http://github.com/singpolyma/haskades+bug-reports: http://github.com/singpolyma/haskades/issues+build-type: Simple+description:+ Autogeneration of bindings for creating BlackBerry Cascades apps+ with Haskell back ends.+ .+ Run as:+ .+ > ./haskades HaskadesBinding.hs haskades_run.cpp < Types.hs+ .+ Where Types.hs is a Haskell file containing a record type declaration+ named 'Slots' and a sum type declaration named 'Signals' which fully+ specifies the communication possible between the UI layer (which you+ write in QML) and the Haskell backend. QML code can access these+ signals and slots on the 'app' context object. Haskell code can emit+ signals by using the 'emit' function exported from the generated+ HaskadesBinding. The 'emit' call is threadsafe.+ .+ Text, Lazy Text, and String all end up as QString so that QML can+ work with them properly, and vice-versa. UTCTime becomes QDateTime.+ Int, Double, and () are passed through fairly directly. Other types+ may have support added as there is need.++extra-source-files:+ README++executable haskades+ main-is: haskades.hs++ other-modules:+ Records,+ MustacheTemplates++ build-depends:+ base == 4.*,+ containers,+ bytestring,+ errors,+ haskell-src,+ text,+ text-format++source-repository head+ type: git+ location: git://github.com/singpolyma/haskades.git
+ haskades.hs view
@@ -0,0 +1,263 @@+module Main (main) where++import Data.List+import Control.Error+import Control.Arrow+import Control.Applicative+import System.Environment (getArgs)+import Language.Haskell.Parser+import Language.Haskell.Syntax+import Data.Text.Lazy.Builder (toLazyText)+import qualified Data.Text.Lazy.IO as TL+import qualified Data.Map as M++import Records+import MustacheTemplates++data Type = TInt | TUTCTime | TDouble | TString | TText | TLText | TUnit deriving (Show, Ord, Eq)+data RType = RPure Type | RIO Type deriving (Show, Eq)++importPrefix :: HsImportDecl -> String+importPrefix (HsImportDecl {importQualified = True, importAs = Just (Module m)}) = m+importPrefix (HsImportDecl {importQualified = True, importAs = Nothing, importModule = (Module m)}) = m+importPrefix _ = ""++doParse :: String -> (String, [(String, Module)], [HsDecl])+doParse moduleSrc = (mod, importEnv, decls)+ where+ importEnv = map (importPrefix &&& importModule) imports+ ParseOk (HsModule _ (Module mod) _ imports decls) = parseModule moduleSrc++dataDeclNamed :: HsName -> HsDecl -> Bool+dataDeclNamed n (HsDataDecl _ _ name _ _ _) | n == name = True+dataDeclNamed _ _ = False++extractTypeFromBangType :: HsBangType -> HsType+extractTypeFromBangType (HsBangedTy t) = t+extractTypeFromBangType (HsUnBangedTy t) = t++flatTyFun :: HsType -> HsType -> ([HsType], HsType)+flatTyFun a (HsTyFun b c) = first (a:) (flatTyFun b c)+flatTyFun a b = ([a], b)++findType :: [(String, Module)] -> Module -> [(Module, Type)] -> Either String Type+findType i (Module m) q =+ headErr ("No " ++ show q ++ " imports find, but one used as type.") matches+ where+ matches = mapMaybe (`lookup` q) $ filter (`elem` moduls) ns+ moduls = map fst q+ ns = map snd $ filter ((==m).fst) i++findTextType :: [(String, Module)] -> Module -> Either String Type+findTextType i m = findType i m [+ (Module "Data.Text", TText),+ (Module "Data.Text.Lazy", TLText)+ ]++findUTCTimeType :: [(String, Module)] -> Module -> Either String Type+findUTCTimeType i m = findType i m [+ (Module "Data.Time", TUTCTime),+ (Module "Data.Time.Clock", TUTCTime)+ ]++resolveType :: [(String, Module)] -> HsType -> Either String Type+resolveType _ (HsTyCon (Special HsUnitCon)) = Right TUnit+resolveType _ (HsTyCon (UnQual (HsIdent "Int"))) = Right TInt+resolveType _ (HsTyCon (UnQual (HsIdent "Double"))) = Right TDouble+resolveType _ (HsTyCon (UnQual (HsIdent "String"))) = Right TString+resolveType i (HsTyCon (UnQual (HsIdent "Text"))) = findTextType i (Module "")+resolveType i (HsTyCon (Qual m (HsIdent "Text"))) = findTextType i m+resolveType i (HsTyCon (UnQual (HsIdent "UTCTime"))) = findUTCTimeType i (Module "")+resolveType i (HsTyCon (Qual m (HsIdent "UTCTime"))) = findUTCTimeType i m+resolveType _ t = Left $ "Type not yet supported: " ++ show t++resolveRType :: [(String, Module)] -> HsType -> Either String RType+resolveRType i (HsTyApp (HsTyCon (UnQual (HsIdent "IO"))) t) = RIO <$> resolveType i t+resolveRType i t = RPure <$> resolveType i t++getSlots :: [(String, Module)] -> [HsDecl] -> Either String [(String, [Type], RType)]+getSlots i decls = slotsDecl >>= slotsFrom >>= mapM slotField+ where+ slotField ([HsIdent fname], t) = case extractTypeFromBangType t of+ (HsTyFun a b) -> let (args, r) = flatTyFun a b in+ (,,) <$> pure fname <*> mapM (resolveType i) args <*> resolveRType i r+ x -> (,,) <$> pure fname <*> pure [] <*> resolveRType i x+ slotField (x, _) = Left $ "Expected field name, found: " ++ show x+ slotsFrom (HsDataDecl _ _ _ _ [HsRecDecl _ (HsIdent "Slots") fields] _) = Right fields+ slotsFrom _ = Left "Type \"Slots\" must have a single record constructor named \"Slots\"."+ slotsDecl = note "No record named \"Slots\" found." $+ find (dataDeclNamed (HsIdent "Slots")) decls++flattenSum :: HsConDecl -> Either String (String, [HsType])+flattenSum (HsConDecl _ (HsIdent n) ts) = Right (n, map extractTypeFromBangType ts)+flattenSum (HsRecDecl _ (HsIdent n) ts) = Right (n, map (extractTypeFromBangType.snd) ts)+flattenSum x = Left $ "Cannot process sum type constructor: " ++ show x++getSignals :: [(String, Module)] -> [HsDecl] -> Either String [(String, [Type])]+getSignals i decls = signalDecl >>= signalsFrom >>= mapM signalConstr+ where+ signalConstr (n, ts) = (,) <$> pure n <*> mapM (resolveType i) ts+ signalsFrom (HsDataDecl _ _ _ _ cons _) = mapM flattenSum cons+ signalsFrom x = Left $ "Could not process signal near: " ++ show x+ signalDecl = note "No sum type named \"Signal\" found." $+ find (dataDeclNamed (HsIdent "Signal")) decls++mapQtType :: Type -> String+mapQtType TInt = "int"+mapQtType TUTCTime = "QDateTime"+mapQtType TDouble = "double"+mapQtType TUnit = "const void *"+mapQtType TString = "QString"+mapQtType TText = "QString"+mapQtType TLText = "QString"++mapLowCType :: Type -> String+mapLowCType TInt = "int"+mapLowCType TUTCTime = "uint" -- Not time_t because of Qt+mapLowCType TDouble = "double"+mapLowCType TUnit = "const void *"+mapLowCType TString = "const char *"+mapLowCType TText = "const char *"+mapLowCType TLText = "const char *"++mapCType :: Type -> String+mapCType TInt = "CInt"+mapCType TUTCTime = "CUInt" -- Not CTime because of Qt+mapCType TDouble = "CDouble"+mapCType TUnit = "()"+mapCType TString = "CString"+mapCType TText = "CString"+mapCType TLText = "CString"++-- We always live in IO on the C side+mapCRType :: RType -> String+mapCRType (RPure t) = "IO " ++ mapCType t+mapCRType (RIO t) = "IO " ++ mapCType t++wrapTypeFromC :: Type -> String -> String+wrapTypeFromC TInt arg = "(return $ fromIntegral " ++ arg ++ ")"+wrapTypeFromC TUTCTime arg = "(return $ posixSecondsToUTCTime $ realToFrac " ++ arg ++ ")"+wrapTypeFromC TDouble arg = "(return $ realToFrac " ++ arg ++ ")"+wrapTypeFromC TString arg = "(fmap (Text.unpack . Text.decodeUtf8) (ByteString.packCString " ++ arg ++ "))"+wrapTypeFromC TText arg = "(fmap Text.decodeUtf8 (ByteString.packCString " ++ arg ++ "))"+wrapTypeFromC TLText arg = "(fmap (LText.fromStrict . Text.decodeUtf8) (ByteString.packCString " ++ arg ++ "))"+wrapTypeFromC _ arg = "(return " ++ arg ++ ")"++wrapTypeToC :: Type -> String -> String+wrapTypeToC TInt arg = "(flip ($) (fromIntegral " ++ arg ++ "))"+wrapTypeToC TUTCTime arg = "(flip ($) (fromInteger $ floor $ utcTimeToPOSIXSeconds " ++ arg ++ "))"+wrapTypeToC TDouble arg = "(flip ($) (realToFrac " ++ arg ++ "))"+wrapTypeToC TString arg = "(ByteString.useAsCString (Text.encodeUtf8 $ Text.pack " ++ arg ++ "))"+wrapTypeToC TText arg = "(ByteString.useAsCString (Text.encodeUtf8 " ++ arg ++ "))"+wrapTypeToC TLText arg = "(ByteString.useAsCString (Text.encodeUtf8 $ LText.toStrict " ++ arg ++ "))"+wrapTypeToC TUnit arg = "(flip ($) (" ++ arg ++ "))"++wrapTypeFromQt :: Type -> String -> String+wrapTypeFromQt TUTCTime arg = "(" ++ arg ++ ").toTime_t()"+wrapTypeFromQt TString arg = "(" ++ arg ++ ").toUtf8().constData()"+wrapTypeFromQt TText arg = "(" ++ arg ++ ").toUtf8().constData()"+wrapTypeFromQt TLText arg = "(" ++ arg ++ ").toUtf8().constData()"+wrapTypeFromQt _ arg = "(" ++ arg ++ ")"++wrapTypeToQt :: Type -> String -> String+wrapTypeToQt TUTCTime arg = "(QDateTime::fromTime_t(" ++ arg ++ "))"+wrapTypeToQt TString arg = "(QString::fromUtf8(" ++ arg ++ "))"+wrapTypeToQt TText arg = "(QString::fromUtf8(" ++ arg ++ "))"+wrapTypeToQt TLText arg = "(QString::fromUtf8(" ++ arg ++ "))"+wrapTypeToQt _ arg = "(" ++ arg ++ ")"++defTypeToC :: Type -> String+defTypeToC TInt = "(flip ($) 0)"+defTypeToC TUTCTime = "(flip ($) 0)"+defTypeToC TDouble = "(flip ($) 0)"+defTypeToC TString = "(flip ($) nullPtr)"+defTypeToC TText = "(flip ($) nullPtr)"+defTypeToC TLText = "(flip ($) nullPtr)"+defTypeToC TUnit = "(flip ($) nullPtr)"++templateSlot :: (String, [Type], RType) -> Slot+templateSlot (fname, args, rtype) = Slot {+ name = fname,+ monadic = case rtype of+ RPure _ -> "(return " ++ fname ++ ")"+ RIO _ -> "(" ++ fname ++ ")",+ hasArgs = not (null args),+ args = zipWith (\i a -> SlotArg {+ firstarg = i == 0,+ aname = "arg" ++ show i,+ ctype = mapCType a,+ lowctype = mapLowCType a,+ qttype = mapQtType a,+ cwrap = wrapTypeFromC a ("arg" ++ show i),+ qtunwrap = wrapTypeFromQt a ("arg" ++ show i)+ }) [(0::Int)..] args,+ crtype = mapCRType rtype,+ crwrap = "(return)" -- TODO+ }++sigCWrap' :: [(Int, Type)] -> [(Int, Type)] -> ([(Int, Int)], [String])+sigCWrap' [] _ = ([], [])+sigCWrap' ((ei,e):es) ts+ | null sameType = -- No more of this type in this signal+ second (("(.) " ++ defTypeToC e) :) (sigCWrap' es ts)+ | otherwise = -- Use up one of this type+ let (idxs, r) = sigCWrap' es (tail sameType ++ rest) in+ ((i, ei) : idxs, ("(.) " ++ wrapTypeToC e ("arg" ++ show i)) : r)+ where+ (i, _) = head sameType+ (sameType, rest) = partition ((==e).snd) ts++sigCWrap :: [Type] -> [(Int, Type)] -> ([(Int, Int)], String)+sigCWrap es ts = (,) idxs $ case wraps of+ [] -> ""+ [x] -> drop 4 x+ (x:xs) -> intercalate " $ (.) $ " (reverse xs) ++ " $ " ++ x+ where+ (idxs, wraps) = second reverse $ sigCWrap' (zip [0..] es) ts++templateSignal :: [Type] -> Integer -> (String, [Type]) -> Signal+templateSignal signalTypes i (name, ts) = Signal {+ signame = name,+ sigargs = zipWith (\i t -> SignalArg {+ sigargfirst = i == 0,+ siganame = "arg" ++ show i,+ qtsigargtype = mapQtType t,+ sigargsigtypename = let Just x = lookup i idxs in "arg" ++ show x+ }) [0..] ts,+ sigevent = i,+ sigcwrap = cwrap+}+ where+ (idxs, cwrap) = sigCWrap signalTypes $ zip [0..] ts++parseArgs :: [String] -> Either String [String]+parseArgs [a,b] = return [a,b]+parseArgs _ =+ Left "Usage: haskades HaskadesBinding.hs haskades_run.cpp < Types.hs"++main :: IO ()+main = runScript $ do+ [hsout, cppout] <- hoistEither . parseArgs =<< scriptIO getArgs++ (mod, importEnv, decls) <- fmap doParse (scriptIO getContents)+ slots <- hoistEither $ getSlots importEnv decls+ signals <- hoistEither $ getSignals importEnv decls+ let signalTypes = concatMap (\(t,c) -> replicate c t) $ M.toAscList $+ M.unionsWith max $ map (M.fromListWith (+) . (`zip` [1,1..]) . snd) signals+ let sigs = zipWith (templateSignal signalTypes) [1..] signals+ let sigTypes = zipWith (\i t -> SignalType {+ csigtype = mapCType t,+ qtsigtype = mapQtType t,+ qtwrapsig = wrapTypeToQt t ("arg" ++ show i),+ lowcsigtype = mapLowCType t,+ sigtypename = "arg" ++ show i+ }) [(0::Int)..] signalTypes+ let template = Template {+ modul = mod,+ slots = map templateSlot slots,+ signalTypes = sigTypes,+ signals = sigs+ }++ scriptIO $ TL.writeFile hsout $ toLazyText $ haskadesBindinghs id template+ scriptIO $ TL.writeFile cppout $ toLazyText $ haskades_runcpp id template