diff --git a/src/compiler/api/GF/Interactive.hs b/src/compiler/api/GF/Interactive.hs index 72ed54bff..2ba7c0813 100644 --- a/src/compiler/api/GF/Interactive.hs +++ b/src/compiler/api/GF/Interactive.hs @@ -372,7 +372,7 @@ updatePGF pgf mb_txnid f = do mb_txnid optLang pgf opts = - case Map.keys (languages pgf) of + case Map.keys langs of [lang] -> completeLang (valStrOpts "lang" lang opts) _ -> case valStrOpts "lang" "" opts of "" -> fail "Specify a language to change" diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 3ee193a20..da25c08bb 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -132,8 +132,7 @@ readPGFWithProbs fpath mb_probs = c_db <- withPgfExn "readPGF" (pgf_read_pgf c_fpath p_revision c_pcallback) c_revision <- peek p_revision fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision - langs <- getConcretes c_db fptr - return (PGF c_db fptr langs) + return (PGF c_db fptr) -- | Reads a PGF file and stores the unpacked data in an NGF file -- ready to be shared with other process, or used for quick startup. @@ -152,8 +151,7 @@ bootNGFWithProbs pgf_path mb_probs ngf_path = c_db <- withPgfExn "bootNGF" (pgf_boot_ngf c_pgf_path c_ngf_path p_revision c_pcallback) c_revision <- peek p_revision fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision - langs <- getConcretes c_db fptr - return (PGF c_db fptr langs) + return (PGF c_db fptr) #if defined(__linux__) || defined(__APPLE__) -- | Similar to 'bootPGF' but instead of reading from a file, @@ -173,8 +171,7 @@ bootNGFWithProbs_ callback mb_probs ngf_path = c_db <- withPgfExn "bootNGF" (pgf_boot_ngf_cookie (castStablePtrToPtr cookie) cookie_read_ptr c_ngf_path p_revision c_pcallback) c_revision <- peek p_revision fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision - langs <- getConcretes c_db fptr - return (PGF c_db fptr langs) + return (PGF c_db fptr) #if defined(__linux__) foreign export ccall cookie_read :: Ptr () -> Ptr Word8 -> CSize -> IO CSize @@ -219,8 +216,7 @@ readNGF fpath = c_db <- withPgfExn "readNGF" (pgf_read_ngf c_fpath p_revision) c_revision <- peek p_revision fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision - langs <- getConcretes c_db fptr - return (PGF c_db fptr langs) + return (PGF c_db fptr) -- | Creates a new NGF file with a grammar with the given abstract_name. -- Aside from the name, the grammar is otherwise empty but can be later @@ -235,7 +231,7 @@ newNGF abs_name mb_fpath init_size = c_db <- withPgfExn "newNGF" (pgf_new_ngf c_abs_name c_fpath (fromIntegral init_size) p_revision) c_revision <- peek p_revision fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision - return (PGF c_db fptr Map.empty) + return (PGF c_db fptr) writePGF :: FilePath -> PGF -> Maybe [ConcName] -> IO () writePGF fpath p mb_langs = @@ -286,6 +282,23 @@ pgfFilePath p = unsafePerformIO $ do then return Nothing else fmap Just $ peekCString c_fpath +languages :: PGF -> Map.Map ConcName Concr +languages p = unsafePerformIO $ do + ref <- newIORef Map.empty + (withForeignPtr (a_revision p) $ \c_revision -> + allocaBytes (#size PgfItor) $ \itor -> + bracket (wrapItorCallback (getConcretes ref)) freeHaskellFunPtr $ \fptr -> do + (#poke PgfItor, fn) itor fptr + withPgfExn "getConcretes" (pgf_iter_concretes (a_db p) c_revision itor) + readIORef ref) + where + getConcretes :: IORef (Map.Map ConcName Concr) -> ItorCallback + getConcretes ref itor key c_revision exn = do + concrs <- readIORef ref + name <- peekText key + fptr <- newForeignPtrEnv pgf_free_concr_revision (a_db p) (castPtr c_revision) + writeIORef ref (Map.insert name (Concr (a_db p) fptr) concrs) + showPGF :: PGF -> String showPGF p = render (text "abstract" <+> ppAbstractName p <+> char '{' $$ diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 0ef1e6f8f..274cca3af 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -26,7 +26,6 @@ type ConcName = String -- ^ Name of concrete syntax -- in Portable Grammar Format. data PGF = PGF { a_db :: Ptr PgfDB , a_revision :: ForeignPtr PGF - , languages :: Map.Map ConcName Concr } data Concr = Concr {c_db :: Ptr PgfDB, c_revision :: ForeignPtr Concr} @@ -724,19 +723,3 @@ withHypos hypos f = (#peek PgfTypeHypo, cid) ptr >>= free (#peek PgfTypeHypo, type) ptr >>= freeStablePtr freeHypos (n-1) (ptr `plusPtr` (#size PgfTypeHypo)) - -getConcretes c_db c_revision = do - ref <- newIORef Map.empty - (withForeignPtr c_revision $ \c_revision -> - allocaBytes (#size PgfItor) $ \itor -> - bracket (wrapItorCallback (getConcretes ref)) freeHaskellFunPtr $ \fptr -> do - (#poke PgfItor, fn) itor fptr - withPgfExn "getConcretes" (pgf_iter_concretes c_db c_revision itor) - readIORef ref) - where - getConcretes :: IORef (Map.Map ConcName Concr) -> ItorCallback - getConcretes ref itor key c_revision exn = do - concrs <- readIORef ref - name <- peekText key - fptr <- newForeignPtrEnv pgf_free_concr_revision c_db (castPtr c_revision) - writeIORef ref (Map.insert name (Concr c_db fptr) concrs) diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index c40ea793c..51aca6082 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -93,8 +93,7 @@ commitTransaction :: TxnID -> IO PGF commitTransaction (TxnID db fptr) = do withForeignPtr fptr $ \c_revision -> withPgfExn "commitTransaction" (pgf_commit_transaction db c_revision) - langs <- getConcretes db fptr - return (PGF db fptr langs) + return (PGF db fptr) rollbackTransaction :: TxnID -> IO () rollbackTransaction (TxnID db fptr) = @@ -129,8 +128,7 @@ modifyPGF p (Transaction f) = ex_type <- (#peek PgfExn, type) c_exn if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE) then do fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision - langs <- getConcretes (a_db p) fptr - return (PGF (a_db p) fptr langs) + return (PGF (a_db p) fptr) else do pgf_free_revision_ (a_db p) c_revision return p else do pgf_free_revision_ (a_db p) c_revision @@ -142,8 +140,7 @@ checkoutPGF :: PGF -> IO PGF checkoutPGF p = do c_revision <- withPgfExn "checkoutPGF" (pgf_checkout_revision (a_db p)) fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision - langs <- getConcretes (a_db p) fptr - return (PGF (a_db p) fptr langs) + return (PGF (a_db p) fptr) {- | 'createFunction name ty arity bytecode prob' creates a new abstract syntax function with the given name, type, arity, etc. If the name