added support for branches and explicit transaction commit

src/runtime/haskell/PGF2/FFI.hsc

@@ -108,11 +108,13 @@ foreign import ccall "pgf_function_is_constructor"
 foreign import ccall "pgf_function_prob"
    pgf_function_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> 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_clone_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> 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 -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfRevision)
+
+foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
 
 
 -----------------------------------------------------------------------
@@ -198,7 +200,7 @@ withPgfExn f =
     res <- f c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     case ex_type of
-      (#const PGF_EXN_NONE)         -> return res
+      (#const PGF_EXN_NONE) -> return res
       (#const PGF_EXN_SYSTEM_ERROR) -> do
          errno <- (#peek PgfExn, code) c_exn
          c_msg <- (#peek PgfExn, msg) c_exn

src/runtime/haskell/PGF2/Transactions.hsc

@@ -1,6 +1,8 @@
 module PGF2.Transactions
           ( Transaction
           , modifyPGF
+          , branchPGF
+          , checkoutPGF
           , createFunction
           ) where
 
@@ -10,7 +12,7 @@ import PGF2.Expr
 import Foreign
 import Foreign.C
 import qualified Foreign.Concurrent as C
-import Control.Exception(bracket)
+import Control.Exception
 
 #include <pgf/pgf.h>
 
@@ -38,19 +40,70 @@ instance Monad Transaction where
              Transaction g -> g c_db c_revision c_exn
       else return undefined
 
+{- | @modifyPGF gr t@ updates the grammar @gr@ by performing the
+   transaction @t@. The changes are applied to the new grammar
+   returned by the function, while any further operations with @gr@
+   will still work with the old grammar. The newly created grammar
+   also replaces the corresponding branch. In the example:
+   
+   > do gr <- readPGF "my_grammar.pgf"
+   >    Just ty = readType "S"
+   >    gr1 <- modifyPGF gr (createFunction "foo" ty)
+   >    gr2 <- checkoutPGF gr "master"
+   >    print (functionType gr2 "foo")
+
+   both @gr1@ and @gr2@ will refer to the new grammar which contains
+   the new function @foo@.
+-}
 modifyPGF :: PGF -> Transaction a -> IO PGF
-modifyPGF p (Transaction f) =
+modifyPGF = branchPGF_ nullPtr
+
+{- | @branchPGF gr branch_name t@ is similar to @modifyPGF gr t@,
+   except that it stores the result as a branch with the given name.
+-}
+branchPGF :: PGF -> String -> Transaction a -> IO PGF
+branchPGF p name t =
+  withText name $ \c_name ->
+    branchPGF_ c_name p t
+
+branchPGF_ :: Ptr PgfText -> PGF -> Transaction a -> IO PGF
+branchPGF_ c_name 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
+  withPgfExn $ \c_exn ->
+  mask $ \restore -> do
+    c_revision <- pgf_clone_revision c_db c_revision c_name 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))
+      then do ((restore (f c_db c_revision c_exn))
+               `catch`
+               (\e -> do
+                    pgf_free_revision c_db c_revision
+                    throwIO (e :: SomeException)))
+              ex_type <- (#peek PgfExn, type) c_exn
+              if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
+                then do pgf_commit_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 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 do pgf_free_revision c_db c_revision
+                                  return p
+                else do pgf_free_revision c_db c_revision
+                        return p
       else return p
 
+{- | Retrieves the branch with the given name -}
+checkoutPGF :: PGF -> String -> IO (Maybe PGF)
+checkoutPGF p name =
+  withForeignPtr (a_db p) $ \c_db ->
+  withText name $ \c_name -> do
+    c_revision <- withPgfExn (pgf_checkout_revision c_db c_name)
+    if c_revision == nullPtr
+      then return Nothing
+      else do fptr2 <- C.newForeignPtr c_revision (withForeignPtr (a_db p) (\c_db -> pgf_free_revision c_db c_revision))
+              return (Just (PGF (a_db p) fptr2 (langs p)))
+
 createFunction :: Fun -> Type -> Float -> Transaction ()
 createFunction name ty prob = Transaction $ \c_db c_revision c_exn ->
   withText name $ \c_name ->

src/runtime/haskell/tests/transactions.hs

@@ -5,12 +5,20 @@ 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)
+
+  gr2 <- modifyPGF gr1              (createFunction "foo" ty pi)
+  gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty pi)
+
+  Just gr4 <- checkoutPGF gr1 "master"
+  Just gr5 <- checkoutPGF gr1 "bar_branch"
 
   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 "branched functions" ["bar","c","ind","s","z"] (functions gr3))
+      ,TestCase (assertEqual "checked-out extended functions" ["c","foo","ind","s","z"] (functions gr4))
+      ,TestCase (assertEqual "checked-out branched functions" ["bar","c","ind","s","z"] (functions gr5))
       ,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"))