diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 0bf9ca548..77a7f532d 100644 --- a/src/compiler/GF/Interactive.hs +++ b/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 = diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index a756eaa4d..9516d216b 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/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)