added working transactions. still not atomic

src/runtime/haskell/PGF2/FFI.hsc

@@ -108,8 +108,11 @@ foreign import ccall "pgf/expr.h pgf_function_is_constructor"
 foreign import ccall "pgf_function_prob"
    pgf_function_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> IO (#type prob_t)
 
+foreign import ccall "pgf_clone_revision"
+   pgf_clone_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO (Ptr PgfRevision)
+
 foreign import ccall "pgf_create_function"
-   pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> IO ()
+   pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
 
 
 -----------------------------------------------------------------------

src/runtime/haskell/PGF2/Transactions.hsc

@@ -0,0 +1,55 @@
+module PGF2.Transactions
+          ( Transaction
+          , modifyPGF
+          , createFunction
+          ) where
+
+import PGF2.FFI
+import PGF2.Expr
+
+import Foreign
+import Foreign.C
+import qualified Foreign.Concurrent as C
+import Control.Exception(bracket)
+
+#include <pgf/pgf.h>
+
+newtype Transaction a =
+  Transaction (Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO a)
+
+instance Functor Transaction where
+  fmap f (Transaction g) = Transaction $ \c_db c_revision c_exn -> do
+    res <- g c_db c_revision c_exn
+    return (f res)
+
+instance Applicative Transaction where
+  pure x = Transaction $ \c_db c_revision c_exn -> return x
+
+instance Monad Transaction where
+  (Transaction f) >>= g = Transaction $ \c_db c_revision c_exn -> do
+    res <- f c_db c_revision c_exn
+    ex_type <- (#peek PgfExn, type) c_exn
+    if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
+      then case g res of
+             Transaction g -> g c_db c_revision c_exn
+      else return undefined
+
+modifyPGF :: PGF -> Transaction a -> IO PGF
+modifyPGF p (Transaction f) =
+  withForeignPtr (a_db p) $ \c_db ->
+  withForeignPtr (revision p) $ \c_revision ->
+  withPgfExn "" $ \c_exn -> do
+    c_revision <- pgf_clone_revision c_db c_revision c_exn
+    ex_type <- (#peek PgfExn, type) c_exn
+    if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
+      then do f c_db c_revision c_exn
+              fptr2 <- C.newForeignPtr c_revision (withForeignPtr (a_db p) (\c_db -> pgf_free_revision c_db c_revision))
+              return (PGF (a_db p) fptr2 (langs p))
+      else return p
+
+createFunction :: Fun -> Type -> Float -> Transaction ()
+createFunction name ty prob = Transaction $ \c_db c_revision c_exn ->
+  withText name $ \c_name ->
+  bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+  withForeignPtr marshaller $ \m -> do
+    pgf_create_function c_db c_revision c_name c_ty prob m c_exn