"create lin/lincat" should be able to see funs & cats in the current transaction

src/compiler/GF/Interactive.hs

@@ -289,20 +289,22 @@ transactionCommand (CreateLin opts f t) pgf mb_txnid = do
   lang <- optLang pgf opts
   mo <- maybe (fail "no source grammar in scope") return $
            greatestResource sgr
-  (fields,ty) <-
-    case functionType pgf f of
-      Just ty -> let DTyp _ cat _ = ty
-                     Just cnc     = Map.lookup lang (languages pgf)
-                     Just fields  = categoryFields cnc cat
-                 in return (fields,type2term mo ty)
-      Nothing -> fail ("Function "++f++" is not in the abstract syntax")
-  case runCheck (compileLinTerm sgr mo t ty) of
-    Ok ((prods,seqtbl,fields'),_)
-         | fields == fields' ->
-                    do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLin f prods seqtbl >> return ()))
-                       return ()
-         | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
-    Bad msg      -> fail msg
+  lift $ updatePGF pgf mb_txnid $ do
+    mb_ty <- getFunctionType f
+    case mb_ty of
+      Just ty@(DTyp _ cat _) -> 
+         alterConcrete lang $ do
+           mb_fields <- getCategoryFields cat
+           case mb_fields of
+             Just fields -> case runCheck (compileLinTerm sgr mo t (type2term mo ty)) of
+                              Ok ((prods,seqtbl,fields'),_)
+                                   | fields == fields' -> do
+                                       createLin f prods seqtbl
+                                       return ()
+                                   | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
+                              Bad msg      -> fail msg
+             Nothing     -> fail ("Category "++cat++" is not in the concrete syntax")
+      _ -> fail ("Function "++f++" is not in the abstract syntax")
   where
     type2term mo (DTyp hypos cat _) =
       foldr (\(b,x,ty1) ty2 -> Prod b (identS x) (type2term mo ty1) ty2)
@@ -422,17 +424,15 @@ fetchCommand gfenv = do
 
 importInEnv :: ReadNGF -> Options -> [FilePath] -> ShellM ()
 importInEnv readNGF opts files =
-  do env <- gets pgfenv
-     case env of
-       (_,pgf0,Nothing) ->
-           case flag optRetainResource opts of
-             RetainAll      -> do src <- lift $ importSource opts files
-                                  pgf <- lift $ link opts pgf0 src
-                                  modify $ \gfenv -> gfenv{pgfenv = (snd src,Just pgf,Nothing)}
-             RetainSource   -> do src <- lift $ importSource opts files
-                                  modify $ \gfenv -> gfenv{pgfenv = (snd src,pgf0,Nothing)}
-             RetainCompiled -> do pgf <- lift $ importPGF pgf0
-                                  modify $ \gfenv -> gfenv{pgfenv = (emptyGrammar,pgf,Nothing)}
+  do (_,pgf0,mb_txnid) <- gets pgfenv
+     case (flag optRetainResource opts,mb_txnid) of
+       (RetainAll,Nothing)      -> do src <- lift $ importSource opts files
+                                      pgf <- lift $ link opts pgf0 src
+                                      modify $ \gfenv -> gfenv{pgfenv = (snd src,Just pgf,Nothing)}
+       (RetainSource,mb_txn)    -> do src <- lift $ importSource opts files
+                                      modify $ \gfenv -> gfenv{pgfenv = (snd src,pgf0,mb_txn)}
+       (RetainCompiled,Nothing) -> do pgf <- lift $ importPGF pgf0
+                                      modify $ \gfenv -> gfenv{pgfenv = (emptyGrammar,pgf,Nothing)}
        _ -> fail "You must commit/rollback the transaction before loading a new grammar"
   where
     importPGF pgf0 =

src/runtime/haskell/PGF2/Transactions.hsc

@@ -32,6 +32,8 @@ module PGF2.Transactions
           , createLin
           , dropLin
           , setPrintName
+          , getFunctionType
+          , getCategoryFields
           ) where
 
 import PGF2.FFI
@@ -41,6 +43,7 @@ import PGF2.ByteCode
 import Foreign
 import Foreign.C
 import Control.Exception
+import qualified Control.Monad.Fail as Fail
 import qualified Data.Sequence as Seq
 import Data.IORef
 
@@ -70,6 +73,14 @@ instance Monad (Transaction k) where
              Transaction g -> g c_db c_abstr c_revision c_exn
       else return undefined
 
+#if !(MIN_VERSION_base(4,13,0))
+  -- Monad(fail) will be removed in GHC 8.8+
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail (Transaction k) where
+  fail msg = Transaction $ \c_db c_abstr c_revision c_exn -> fail msg
+
 data TxnID = TxnID (Ptr PgfDB) (ForeignPtr PGF)
 
 startTransaction :: PGF -> IO TxnID
@@ -166,7 +177,7 @@ createConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_e
           (pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
     f c_db c_abstr c_concr_revision c_exn
 
-alterConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
+alterConcrete :: ConcName -> Transaction Concr a -> Transaction PGF a
 alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn ->
   withText name $ \c_name -> do
   bracket (pgf_clone_concrete c_db c_revision c_name c_exn)
@@ -383,4 +394,45 @@ setPrintName :: Fun -> String -> Transaction Concr ()
 setPrintName fun name = Transaction $ \c_db _ c_revision c_exn ->
   withText fun $ \c_fun ->
   withText name $ \c_name -> do
-    withPgfExn "setPrintName" (pgf_set_printname c_db c_revision c_fun c_name)
+    pgf_set_printname c_db c_revision c_fun c_name c_exn
+
+-- | A monadic version of 'functionType' which returns the type of
+-- the function in the current transaction.
+getFunctionType :: Fun -> Transaction PGF (Maybe Type)
+getFunctionType fun = Transaction $ \c_db c_revision _ c_exn -> do
+  c_typ <- withForeignPtr unmarshaller $ \u ->
+           withText fun $ \c_fun ->
+             pgf_function_type c_db c_revision c_fun u c_exn
+  ex_type <- (#peek PgfExn, type) c_exn
+  if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
+    then if c_typ == castPtrToStablePtr nullPtr
+           then return Nothing
+           else do typ <- deRefStablePtr c_typ
+                   freeStablePtr c_typ
+                   return (Just typ)
+    else return undefined
+
+-- | A monadic version of 'categoryFields' which returns the fields of
+-- a category from grammar in the current transaction.
+getCategoryFields :: Cat -> Transaction Concr (Maybe [String])
+getCategoryFields cat = Transaction $ \c_db _ c_revision c_exn ->
+  withText cat $ \c_cat ->
+  alloca $ \p_n_fields -> do
+    c_fields <- pgf_category_fields c_db c_revision c_cat p_n_fields c_exn
+    ex_type <- (#peek PgfExn, type) c_exn
+    if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
+      then if c_fields == nullPtr
+             then return Nothing
+             else do n_fields <- peek p_n_fields
+                     fs <- peekFields n_fields c_fields
+                     free c_fields
+                     return (Just fs)
+      else return undefined
+  where
+    peekFields n_fields c_fields
+      | n_fields == 0 = return []
+      | otherwise     = do c_text <- peek c_fields
+                           f  <- peekText c_text
+                           free c_text
+                           fs <- peekFields (n_fields-1) (c_fields `plusPtr` (#size PgfText*))
+                           return (f:fs)