introduce probspace and maintain consistency after delete

src/runtime/haskell/PGF2.hsc

@@ -340,7 +340,7 @@ abstractName :: PGF -> AbsName
 abstractName p =
   unsafePerformIO $
   withForeignPtr (a_revision p) $ \c_revision ->
-  bracket (withPgfExn "abstractName" (pgf_abstract_name (a_db p) c_revision)) free $ \c_text ->
+  bracket (withPgfExn "abstractName" (pgf_abstract_name (a_db p) c_revision)) free $ \c_text -> do
     peekText c_text
 
 -- | The start category is defined in the grammar with

src/runtime/haskell/PGF2/FFI.hsc

@@ -233,11 +233,11 @@ foreign import ccall "dynamic" callLinBuilder7 :: Dynamic (Ptr PgfLinBuilderIfac
 
 foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_has_linearization :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO CInt
 
@@ -371,7 +371,7 @@ utf8Length s = count 0 s
 -- Exceptions
 
 data PGFError = PGFError String String
-     deriving Typeable
+     deriving (Eq,Typeable)
 
 instance Show PGFError where
   show (PGFError loc msg) = loc++": "++msg

src/runtime/haskell/PGF2/Transactions.hsc

@@ -150,6 +150,8 @@ checkoutPGF p = do
      contains %d, %x or %a then the pattern is replaced with a random
      number in base 10, 16, or 36, which guarantees that the name is
      unique. The returned name is the final name after the substitution.
+     If there is no substitution pattern in the name, and there is
+     already a function with the same name then an exception is thrown.
 -}
 createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF Fun
 createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn ->
@@ -284,9 +286,9 @@ createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_
         withTexts p (i+1) ss f
 
 dropLincat :: Cat -> Transaction Concr ()
-dropLincat name = Transaction $ \c_db _ c_revision c_exn ->
+dropLincat name = Transaction $ \c_db  c_abstr c_revision c_exn ->
   withText name $ \c_name ->
-    pgf_drop_lincat c_db c_revision c_name c_exn
+    pgf_drop_lincat c_db  c_abstr c_revision c_name c_exn
 
 createLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
 createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
@@ -406,9 +408,9 @@ withBuildLinIface prods seqtbl f = do
           pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms
 
 dropLin :: Fun -> Transaction Concr ()
-dropLin name = Transaction $ \c_db _ c_revision c_exn ->
+dropLin name = Transaction $ \c_db c_abstr c_revision c_exn ->
   withText name $ \c_name ->
-    pgf_drop_lin c_db c_revision c_name c_exn
+    pgf_drop_lin c_db c_abstr c_revision c_name c_exn
 
 setPrintName :: Fun -> String -> Transaction Concr ()
 setPrintName fun name = Transaction $ \c_db _ c_revision c_exn ->

src/runtime/haskell/tests/transactions.hs

@@ -4,34 +4,54 @@ import PGF2.Transactions
 import System.Mem
 import System.Exit (exitSuccess, exitFailure)
 import qualified Data.Map as Map
+import Control.Exception (try)
 
 main = do
   gr1 <- readPGF "tests/basic.pgf"
   let Just ty = readType "(N -> N) -> P (s z)"
 
+  excpt1 <- try (modifyPGF gr1 (createFunction "c" ty 0 [] pi) >> return ())
+  excpt2 <- try (modifyPGF gr1 (createCategory "N" [] pi) >> return ())
+
   gr2 <- modifyPGF gr1 (createFunction "foo" ty 0 [] pi >>
                         createCategory "Q" [(Explicit,"x",ty)] pi)
 
   gr4 <- checkoutPGF gr1
 
   gr6 <- modifyPGF gr1 (dropFunction "ind" >> dropCategory "S")
+  let Just cnc6 = Map.lookup "basic_cnc" (languages gr6)
 
   gr7 <- modifyPGF gr1 $
            createConcrete "basic_eng" $ do
              setConcreteFlag "test_flag" (LStr "test")
+  let Just cnc7 = Map.lookup "basic_eng" (languages gr7)
+
+  gr8 <- modifyPGF gr1 $
+           alterConcrete "basic_cnc" $ do
+             dropLin "z"
+  let Just cnc8 = Map.lookup "basic_cnc" (languages gr8)
+
+  gr9 <- modifyPGF gr1 $
+           alterConcrete "basic_cnc" $ do
+             dropLincat "N"
+  let Just cnc9 = Map.lookup "basic_cnc" (languages gr9)
+
+  excpt3 <- try (modifyPGF gr1 (alterConcrete "basic_foo" (return ())) >> return ())
 
-  let Just cnc = Map.lookup "basic_eng" (languages gr7)
 
   c <- runTestTT $
     TestList $
       [TestCase (assertEqual "original functions" ["c","floatLit","ind","intLit","nat","s","stringLit","z"] (functions gr1))
+      ,TestCase (assertEqual "existing function" (Left (PGFError "modifyPGF" "A function with that name already exists")) excpt1)
+      ,TestCase (assertEqual "existing category" (Left (PGFError "modifyPGF" "A category with that name already exists")) excpt2)
       ,TestCase (assertEqual "extended functions" ["c","floatLit","foo","ind","intLit","nat","s","stringLit","z"] (functions gr2))
       ,TestCase (assertEqual "checked-out extended functions" ["c","floatLit","foo","ind","intLit","nat","s","stringLit","z"] (functions gr4))
       ,TestCase (assertEqual "original categories" ["Float","Int","N","P","S","String"] (categories gr1))
       ,TestCase (assertEqual "extended categories" ["Float","Int","N","P","Q","S","String"] (categories gr2))
       ,TestCase (assertEqual "Q context" (Just [(Explicit,"x",ty)]) (categoryContext gr2 "Q"))
-      ,TestCase (assertEqual "reduced functions" ["c","floatLit","foo","intLit","nat","s","stringLit","z"] (functions gr6))
+      ,TestCase (assertEqual "reduced functions" ["foo","nat","s","z"] (functions gr6))
       ,TestCase (assertEqual "reduced categories" ["Float","Int","N","P","Q","String"] (categories gr6))
+      ,TestCase (assertEqual "reduced lins" [False,False,False,False,True,True,False,True] (map (hasLinearization cnc6) ["c","floatLit","foo","intLit","nat","s","stringLit","z"]))
       ,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)  (functionProbability gr1 "foo"))
@@ -40,7 +60,10 @@ main = do
       ,TestCase (assertEqual "new category prob" pi        (categoryProbability gr2 "Q"))
       ,TestCase (assertEqual "empty concretes" ["basic_cnc"] (Map.keys (languages gr1)))
       ,TestCase (assertEqual "extended concretes" ["basic_cnc","basic_eng"] (Map.keys (languages gr7)))
-      ,TestCase (assertEqual "added concrete flag" (Just (LStr "test")) (concreteFlag cnc "test_flag"))
+      ,TestCase (assertEqual "added concrete flag" (Just (LStr "test")) (concreteFlag cnc7 "test_flag"))
+      ,TestCase (assertEqual "alter missing concrete" (Left (PGFError "modifyPGF" "Unknown concrete syntax")) excpt3)
+      ,TestCase (assertEqual "drop lin" (True,False) (hasLinearization cnc8 "s",hasLinearization cnc8 "z"))
+      ,TestCase (assertEqual "drop lincat" (False,False) (hasLinearization cnc9 "s",hasLinearization cnc9 "z"))
       ]
 
   performMajorGC