added working transactions. still not atomic

src/runtime/haskell/PGF2.hsc

@@ -40,8 +40,6 @@ module PGF2 (-- * PGF
              mkType, unType,
              mkHypo, mkDepHypo, mkImplHypo,
 
-             createFunction,
-
              -- * Concrete syntax
              ConcName,
 
@@ -49,13 +47,13 @@ module PGF2 (-- * PGF
              PGFError(..)
              ) where
 
-import Control.Exception(mask_,bracket)
-import System.IO.Unsafe(unsafePerformIO)
 import PGF2.Expr
 import PGF2.FFI
 
 import Foreign
 import Foreign.C
+import Control.Exception(mask_,bracket)
+import System.IO.Unsafe(unsafePerformIO)
 import qualified Foreign.Concurrent as C
 import qualified Data.Map as Map
 import Data.IORef
@@ -336,12 +334,3 @@ readType str =
       else do ty <- deRefStablePtr c_ty
               freeStablePtr c_ty
               return (Just ty)
-
-createFunction :: PGF -> Fun -> Type -> Float -> IO ()
-createFunction p name ty prob =
-  withForeignPtr (a_db p) $ \c_db ->
-  withForeignPtr (revision p) $ \c_revision ->
-  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

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

src/runtime/haskell/pgf2.cabal

@@ -22,6 +22,7 @@ extra-source-files:
 library
   exposed-modules:
     PGF2,
+    PGF2.Transactions,
     PGF2.Internal,
     -- backwards compatibility API:
     PGF
@@ -53,3 +54,12 @@ test-suite basic
     random,
     directory,
     pgf2
+
+test-suite transactions
+  type: exitcode-stdio-1.0
+  main-is: tests/transactions.hs
+  default-language: Haskell2010
+  build-depends:
+    base,
+    HUnit,
+    pgf2

src/runtime/haskell/tests/basic.hs

@@ -74,11 +74,8 @@ main = do
     print (e :: SomeException)
 
   gr1 <- readPGF "tests/basic.pgf"
-  print (abstractName gr1)
   gr2 <- bootNGF "tests/basic.pgf" "tests/basic.ngf"
-  print (abstractName gr2)
   gr3 <- readNGF "tests/basic.ngf"
-  print (abstractName gr3)
 
   rp1 <- testLoadFailure (readPGF "non-existing.pgf")
   rp2 <- testLoadFailure (readPGF "tests/basic.gf")

src/runtime/haskell/tests/transactions.hs

@@ -0,0 +1,18 @@
+import Test.HUnit
+import PGF2
+import PGF2.Transactions
+
+main = do
+  gr1 <- readPGF "tests/basic.pgf"
+  let Just ty = readType "(N -> N) -> P (s z)"
+  gr2 <- modifyPGF gr1 (createFunction "foo" ty pi)
+
+  runTestTTAndExit $
+    TestList $
+      [TestCase (assertEqual "original functions" ["c","ind","s","z"] (functions gr1))
+      ,TestCase (assertEqual "extended functions" ["c","foo","ind","s","z"] (functions gr2))
+      ,TestCase (assertEqual "old function type" Nothing   (functionType gr1 "foo"))
+      ,TestCase (assertEqual "new function type" (Just ty) (functionType gr2 "foo"))
+      ,TestCase (assertEqual "old function prob" (-log 0)  (functionProb gr1 "foo"))
+      ,TestCase (assertEqual "new function prob" pi        (functionProb gr2 "foo"))
+      ]