diff --git a/src/compiler/api/GF/Command/Commands.hs b/src/compiler/api/GF/Command/Commands.hs index fb3cc24ec..d796d4e62 100644 --- a/src/compiler/api/GF/Command/Commands.hs +++ b/src/compiler/api/GF/Command/Commands.hs @@ -247,6 +247,7 @@ pgfCommands = Map.fromList [ ], options = [ ("retain","retain operations (used for cc command)"), + ("resource","the grammar is loaded as a resource to a precompiled PGF"), ("src", "force compilation from source"), ("v", "be verbose - show intermediate status information") ], diff --git a/src/compiler/api/GF/Command/Importing.hs b/src/compiler/api/GF/Command/Importing.hs index d112acf6a..8d483198d 100644 --- a/src/compiler/api/GF/Command/Importing.hs +++ b/src/compiler/api/GF/Command/Importing.hs @@ -79,8 +79,8 @@ importPGF opts (Just pgf) f = fmap Just (modifyPGF pgf (mergePGF f) `catc readPGF f else throwIO e)) -importSource :: Options -> [FilePath] -> IO (ModuleName,SourceGrammar) -importSource opts files = fmap snd (batchCompile opts files) +importSource :: Options -> Maybe PGF -> [FilePath] -> IO (ModuleName,SourceGrammar) +importSource opts mb_pgf files = fmap snd (batchCompile opts mb_pgf files) -- for different cf formats importCF opts files get convert = impCF diff --git a/src/compiler/api/GF/Compile.hs b/src/compiler/api/GF/Compile.hs index 6e9215272..59524de8c 100644 --- a/src/compiler/api/GF/Compile.hs +++ b/src/compiler/api/GF/Compile.hs @@ -7,7 +7,7 @@ import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles, import GF.CompileOne(compileOne) import GF.Grammar.Grammar(Grammar,emptyGrammar,modules,mGrammar, - abstractOfConcrete,prependModule)--,msrc,modules + abstractOfConcrete,prependModule,ModuleInfo(..)) import GF.Infra.CheckM import GF.Infra.Ident(ModuleName,moduleNameS)--,showIdent @@ -19,17 +19,17 @@ import GF.Data.Operations(raise,(+++),err) import Control.Monad(foldM,when,(<=<)) import GF.System.Directory(getCurrentDirectory,doesFileExist,getModificationTime) import System.FilePath((),isRelative,dropFileName) -import qualified Data.Map as Map(empty,insert,elems) --lookup +import qualified Data.Map as Map(empty,singleton,insert,elems) import Data.List(nub) import Data.Time(UTCTime) import GF.Text.Pretty(render,($$),(<+>),nest) -import PGF2(PGF,readProbabilitiesFromFile) +import PGF2(PGF,abstractName,pgfFilePath,readProbabilitiesFromFile) -- | Compiles a number of source files and builds a 'PGF' structure for them. -- This is a composition of 'link' and 'batchCompile'. compileToPGF :: Options -> Maybe PGF -> [FilePath] -> IOE PGF -compileToPGF opts mb_pgf fs = link opts mb_pgf . snd =<< batchCompile opts fs +compileToPGF opts mb_pgf fs = link opts mb_pgf . snd =<< batchCompile opts mb_pgf fs -- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and -- 'PGF.parse' with the "PGF" run-time system. @@ -56,12 +56,15 @@ srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc -- used, in which case tags files are produced instead). -- Existing @.gfo@ files are reused if they are up-to-date -- (unless the option @-src@ aka @-force-recomp@ is used). -batchCompile :: Options -> [FilePath] -> IOE (UTCTime,(ModuleName,Grammar)) -batchCompile opts files = do - (gr,menv) <- foldM (compileModule opts) emptyCompileEnv files +batchCompile :: Options -> Maybe PGF -> [FilePath] -> IOE (UTCTime,(ModuleName,Grammar)) +batchCompile opts mb_pgf files = do + menv <- emptyCompileEnv mb_pgf + (gr,menv) <- foldM (compileModule opts) menv files let cnc = moduleNameS (justModuleName (last files)) - t = maximum . map fst $ Map.elems menv + t = maximum . map snd3 $ Map.elems menv return (t,(cnc,gr)) + where + snd3 (_,y,_) = y -- | compile with one module as starting point -- command-line options override options (marked by --#) in the file @@ -105,14 +108,23 @@ compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr -- | The environment type CompileEnv = (Grammar,ModEnv) -emptyCompileEnv :: CompileEnv -emptyCompileEnv = (emptyGrammar,Map.empty) +emptyCompileEnv :: Maybe PGF -> IOE CompileEnv +emptyCompileEnv mb_pgf = do + case mb_pgf of + Just pgf -> do let fpath = pgfFilePath pgf + abs_name = abstractName pgf + t <- getModificationTime fpath + return ( prependModule emptyGrammar (moduleNameS abs_name, ModPGF pgf) + , Map.singleton abs_name (fpath,t,[]) + ) + Nothing -> return (emptyGrammar,Map.empty) + extendCompileEnv (gr,menv) (mfile,mo) = do menv2 <- case mfile of Just file -> do let (mod,imps) = importsOfModule mo t <- getModificationTime file - return $ Map.insert mod (t,imps) menv + return $ Map.insert mod (file,t,imps) menv _ -> return menv return (prependModule gr mo,menv2) diff --git a/src/compiler/api/GF/Compile/ReadFiles.hs b/src/compiler/api/GF/Compile/ReadFiles.hs index 9396b3a2f..c92703112 100644 --- a/src/compiler/api/GF/Compile/ReadFiles.hs +++ b/src/compiler/api/GF/Compile/ReadFiles.hs @@ -50,7 +50,7 @@ import System.FilePath import GF.Text.Pretty type ModName = String -type ModEnv = Map.Map ModName (UTCTime,[ModName]) +type ModEnv = Map.Map ModName (FilePath,UTCTime,[ModName]) -- | Returns a list of all files to be compiled in topological order i.e. @@ -98,14 +98,17 @@ getAllFiles opts ps env file = do -- returns 'ModuleInfo'. It fails if there is no such module --findModule :: ModName -> IOE ModuleInfo findModule name = do - (file,gfTime,gfoTime) <- findFile gfoDir ps name + (file,gfTime,gfoTime) <- findFile gfoDir ps env name let mb_envmod = Map.lookup name env - (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime + (st,t) = selectFormat opts (fmap snd3 mb_envmod) gfTime gfoTime + + snd3 (_,y,_) = y + thd3 (_,_,z) = z (st,(mname,imps)) <- case st of - CSEnv -> return (st, (name, maybe [] snd mb_envmod)) + CSEnv -> return (st, (name, maybe [] thd3 mb_envmod)) CSRead -> do let gfo = if isGFO file then file else gf2gfo opts file t_imps <- gfoImports gfo case t_imps of @@ -121,8 +124,8 @@ getAllFiles opts ps env file = do return (name,st,t,isJust gfTime,imps,dropFileName file) -------------------------------------------------------------------------------- -findFile gfoDir ps name = - maybe noSource haveSource =<< getFilePath ps (gfFile name) +findFile gfoDir ps env name = + maybe noSource haveSource =<< getFilePath ps (gfFile name) where haveSource gfFile = do gfTime <- getModificationTime gfFile @@ -130,7 +133,7 @@ findFile gfoDir ps name = return (gfFile, Just gfTime, mb_gfoTime) noSource = - maybe noGFO haveGFO =<< getFilePath gfoPath (gfoFile name) + maybe noGFO haveGFO =<< getFilePath gfoPath (gfoFile name) where gfoPath = maybe id (:) gfoDir ps @@ -138,8 +141,11 @@ findFile gfoDir ps name = do gfoTime <- getModificationTime gfoFile return (gfoFile, Nothing, Just gfoTime) - noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$ - "searched in:" <+> vcat ps)) + noGFO = + case Map.lookup name env of + Just (fpath,t,_) -> return (fpath, Nothing, Nothing) + Nothing -> raise (render ("File" <+> gfFile name <+> "does not exist." $$ + "searched in:" <+> vcat ps <+> (show (env :: Map.Map ModName (FilePath,UTCTime,[ModName]))))) gfImports opts file = importsOfModule `fmap` parseModHeader opts file diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs index cbb8a52ff..1fe236394 100644 --- a/src/compiler/api/GF/Compile/Rename.hs +++ b/src/compiler/api/GF/Compile/Rename.hs @@ -36,6 +36,7 @@ import GF.Grammar.Lookup import GF.Grammar.Macros import GF.Grammar.Printer import GF.Data.Operations +import PGF2(abstractName,functionType,categoryContext) import Control.Monad import Data.List (nub,(\\)) @@ -58,10 +59,7 @@ renameModule cwd gr mo@(m,mi) = do return (m, mi{jments = js}) type Status = (StatusMap, [(OpenSpec, StatusMap)]) - -type StatusMap = Map.Map Ident StatusInfo - -type StatusInfo = Ident -> Term +type StatusMap = Ident -> Maybe Term -- Delays errors, allowing many errors to be detected and reported renameIdentTerm env = accumulateError (renameIdentTerm' env) @@ -74,14 +72,12 @@ renameIdentTerm' env@(act,imps) t0 = Cn c -> ident (\_ s -> checkError s) c Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 Q (m',c) -> do - m <- lookupErr m' qualifs - f <- lookupIdent c m - return $ f c + f <- lookupErr m' qualifs + maybe (notFound c) return (f c) QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 QC (m',c) -> do - m <- lookupErr m' qualifs - f <- lookupIdent c m - return $ f c + f <- lookupErr m' qualifs + maybe (notFound c) return (f c) _ -> return t0 where opens = [st | (OSimple _,st) <- imps] @@ -95,67 +91,68 @@ renameIdentTerm' env@(act,imps) t0 = | otherwise = checkError s ident alt c = - case Map.lookup c act of - Just f -> return (f c) - _ -> case mapMaybe (Map.lookup c) opens of - [f] -> return (f c) + case act c of + Just t -> return t + _ -> case mapMaybe (\f -> f c) opens of + [t] -> return t [] -> alt c ("constant not found:" <+> c $$ "given" <+> fsep (punctuate ',' (map fst qualifs))) - fs -> case nub [f c | f <- fs] of - [tr] -> return tr + ts -> case nub ts of + [t] -> return t ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$ "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$ "given" <+> fsep (punctuate ',' (map fst qualifs))) - return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others. - where - -- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56 - -- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06 - notFromCommonModule :: Term -> Bool - notFromCommonModule term = - let t = render $ ppTerm Qualified 0 term :: String - in not $ any (\moduleName -> moduleName `L.isPrefixOf` t) - ["CommonX", "ConstructX", "ExtendFunctor" - ,"MarkHTMLX", "ParamX", "TenseX", "TextX"] - - -- If one of the terms comes from the common modules, - -- we choose the other one, because that's defined in the grammar. - bestTerm :: [Term] -> Term - bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_) - bestTerm ts@(t:_) = - let notCommon = [t | t <- ts, notFromCommonModule t] - in case notCommon of - [] -> t -- All terms are from common modules, return first of original list - (u:_) -> u -- ≥1 terms are not from common modules, return first of those - -info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo + return t + +info2status :: Maybe ModuleName -> Ident -> Info -> Term info2status mq c i = case i of - AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq - ResValue _ _ -> maybe Con (curry QC) mq - ResParam _ _ -> maybe Con (curry QC) mq - AnyInd True m -> maybe Con (const (curry QC m)) mq - AnyInd False m -> maybe Cn (const (curry Q m)) mq - _ -> maybe Cn (curry Q) mq + AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq c + ResValue _ _ -> maybe Con (curry QC) mq c + ResParam _ _ -> maybe Con (curry QC) mq c + AnyInd True m -> maybe Con (const (curry QC m)) mq c + AnyInd False m -> maybe Cn (const (curry Q m)) mq c + _ -> maybe Cn (curry Q) mq c tree2status :: OpenSpec -> Map.Map Ident Info -> StatusMap -tree2status o = case o of - OSimple i -> Map.mapWithKey (info2status (Just i)) - OQualif i j -> Map.mapWithKey (info2status (Just j)) +tree2status o map = case o of + OSimple i -> flip Map.lookup (Map.mapWithKey (info2status (Just i)) map) + OQualif i j -> flip Map.lookup (Map.mapWithKey (info2status (Just j)) map) buildStatus :: FilePath -> Grammar -> Module -> Check Status buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do let gr1 = prependModule gr mo - exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m] - ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi) - let sts = map modInfo2status (exts++ops) + exts = [(o,modInfo2status o mi) | (m,mi) <- allExtends gr1 m, let o = OSimple m] + ops <- mapM (openSpec2status gr1) (mopens mi) + let sts = exts++ops return (if isModCnc mi - then (Map.empty, reverse sts) -- the module itself does not define any names - else (self2status m mi,reverse sts)) -- so the empty ident is not needed + then (const Nothing, reverse sts) -- the module itself does not define any names + else (self2status m mi,reverse sts)) + +openSpec2status gr o = + do mi <- lookupModule gr (openedModule o) + return (o,modInfo2status o mi) + where + mn = openedModule o + +pgf2status o pgf id = + case functionType pgf sid of + Just _ -> Just (QC (mn, id)) + Nothing -> case categoryContext pgf sid of + Just _ -> Just (QC (mn, id)) + Nothing -> Nothing + where + sid = showIdent id + + mn = case o of + OSimple i -> i + OQualif i j -> j -modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap) -modInfo2status (o,mo) = (o,tree2status o (jments mo)) +modInfo2status :: OpenSpec -> ModuleInfo -> StatusMap +modInfo2status o (ModInfo{jments=jments}) = tree2status o jments +modInfo2status o (ModPGF pgf) = pgf2status o pgf self2status :: ModuleName -> ModuleInfo -> StatusMap -self2status c m = Map.mapWithKey (info2status (Just c)) (jments m) +self2status c m = flip Map.lookup (Map.mapWithKey (info2status (Just c)) (jments m)) renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info diff --git a/src/compiler/api/GF/Compile/Update.hs b/src/compiler/api/GF/Compile/Update.hs index cf4ba94ea..67688f279 100644 --- a/src/compiler/api/GF/Compile/Update.hs +++ b/src/compiler/api/GF/Compile/Update.hs @@ -57,6 +57,10 @@ extendModule cwd gr (name,m) extOne mo (n,cond) = do m0 <- lookupModule gr n + case m0 of + ModPGF _ -> checkError ("cannot extend the precompiled module" <+> n) + _ -> return () + -- test that the module types match, and find out if the old is complete unless (sameMType (mtype m) (mtype mo)) (checkError ("illegal extension type to module" <+> name)) diff --git a/src/compiler/api/GF/CompileInParallel.hs b/src/compiler/api/GF/CompileInParallel.hs index 0b0a81312..c2846fd37 100644 --- a/src/compiler/api/GF/CompileInParallel.hs +++ b/src/compiler/api/GF/CompileInParallel.hs @@ -110,12 +110,12 @@ batchCompile1 lib_dir (opts,filepaths) = -- logStrLn $ "Finished "++show (length (modules gr'))++" modules." return gr' fcache <- liftIO $ newIOCache $ \ _ (imp,Hide (f,ps)) -> - do (file,_,_) <- findFile gfoDir ps imp + do (file,_,_) <- findFile gfoDir ps M.empty imp return (file,(f,ps)) let find f ps imp = do (file',(f',ps')) <- liftIO $ readIOCache fcache (imp,Hide (f,ps)) when (ps'/=ps) $ - do (file,_,_) <- findFile gfoDir ps imp + do (file,_,_) <- findFile gfoDir ps M.empty imp unless (file==file' || any fromPrelude [file,file']) $ do eq <- liftIO $ (==) <$> BS.readFile file <*> BS.readFile file' unless eq $ diff --git a/src/compiler/api/GF/CompileOne.hs b/src/compiler/api/GF/CompileOne.hs index 2ef1eb8dd..e421f04ee 100644 --- a/src/compiler/api/GF/CompileOne.hs +++ b/src/compiler/api/GF/CompileOne.hs @@ -96,8 +96,8 @@ compileSourceModule opts cwd mb_gfFile gr = else generateGFO <=< ifComplete (backend <=< middle) <=< frontend where -- Apply to all modules - frontend = runPass Extend "" . extendModule cwd gr - <=< runPass Rebuild "" . rebuildModule cwd gr + frontend = runPass Extend "extending" . extendModule cwd gr + <=< runPass Rebuild "rebuilding" . rebuildModule cwd gr -- Apply to complete modules middle = runPass TypeCheck "type checking" . checkModule opts cwd gr diff --git a/src/compiler/api/GF/Compiler.hs b/src/compiler/api/GF/Compiler.hs index 9e8b6cb07..4076a0e70 100644 --- a/src/compiler/api/GF/Compiler.hs +++ b/src/compiler/api/GF/Compiler.hs @@ -54,7 +54,7 @@ compileSourceFiles opts fs = linkGrammars opts output where batchCompile = maybe batchCompile' parallelBatchCompile (flag optJobs opts) - batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs + batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts Nothing fs return (t,[cnc_gr]) exportCanonical (_time, canonical) = diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs index edef77536..cd992810d 100644 --- a/src/compiler/api/GF/Grammar/Grammar.hs +++ b/src/compiler/api/GF/Grammar/Grammar.hs @@ -73,7 +73,7 @@ import GF.Infra.Location import GF.Data.Operations -import PGF2(BindType(..)) +import PGF2(BindType(..),PGF) import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)) import Data.Array.IArray(Array) @@ -86,13 +86,14 @@ import GF.Text.Pretty -- | A grammar is a self-contained collection of grammar modules data Grammar = MGrammar { moduleMap :: Map.Map ModuleName ModuleInfo, - modules :: [Module] + modules :: [Module] } -- | Modules type Module = (ModuleName, ModuleInfo) -data ModuleInfo = ModInfo { +data ModuleInfo + = ModInfo { mtype :: ModuleType, mstatus :: ModuleStatus, mflags :: Options, @@ -103,7 +104,10 @@ data ModuleInfo = ModInfo { msrc :: FilePath, mseqs :: Maybe (Seq.Seq [Symbol]), jments :: Map.Map Ident Info - } + } + | ModPGF { + mpgf :: PGF + } type SourceGrammar = Grammar type SourceModule = Module diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs index e04965967..c469ecc97 100644 --- a/src/compiler/api/GF/Grammar/Lookup.hs +++ b/src/compiler/api/GF/Grammar/Lookup.hs @@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- module GF.Grammar.Lookup ( - lookupIdent, + lookupIdent, notFound, lookupOrigInfo, allOrigInfos, lookupResDef, @@ -43,6 +43,7 @@ import GF.Grammar.Lockfield import Data.List (sortBy) import GF.Text.Pretty import qualified Data.Map as Map +import qualified PGF2 -- whether lock fields are added in reuse lock c = lockRecType c -- return @@ -53,13 +54,46 @@ lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b lookupIdent c t = case Map.lookup c t of Just v -> return v - Nothing -> raise ("unknown identifier" +++ showIdent c) + Nothing -> notFound c + +notFound c = raise ("unknown identifier" +++ showIdent c) + +lookupIdentInfo :: ErrorMonad m => SourceModule -> Ident -> m Info +lookupIdentInfo (m,ModInfo{jments=js}) i = lookupIdent i js +lookupIdentInfo (m,ModPGF{mpgf=pgf}) i = + case PGF2.functionType pgf (showIdent i) of + Just ty -> return (ResValue (noLoc (cnvType [] ty)) 0) + Nothing -> case PGF2.categoryContext pgf (showIdent i) of + Just ctxt -> return (ResParam Nothing Nothing) + Nothing -> notFound i + where + cnvType xs (PGF2.DTyp hypos cat es) = + appHypos hypos xs (QC (m,identS cat)) es + + appHypos [] xs t es = + foldl (appExpr xs) t es + appHypos ((bt, v, ty):hypos) xs t es = + let x = identS v in Prod bt x (cnvType xs ty) (appHypos hypos (x:xs) t es) + + appExpr xs t e = App t (cnvExpr xs e) + + cnvExpr xs (PGF2.EAbs bt v e) = let x = identS v in Abs bt x (cnvExpr (x:xs) e) + cnvExpr xs (PGF2.EApp e1 e2) = App (cnvExpr xs e1) (cnvExpr xs e2) + cnvExpr xs (PGF2.ELit (PGF2.LStr s)) = K s + cnvExpr xs (PGF2.ELit (PGF2.LInt n)) = EInt n + cnvExpr xs (PGF2.ELit (PGF2.LFlt n)) = EFloat n + cnvExpr xs (PGF2.EMeta i) = Meta i + cnvExpr xs (PGF2.EFun f) = QC (m,identS f) + cnvExpr xs (PGF2.EVar i) = Vr (xs !! i) + cnvExpr xs (PGF2.ETyped e ty) = Typed (cnvExpr xs e) (cnvType xs ty) + cnvExpr xs (PGF2.EImplArg e) = ImplArg (cnvExpr xs e) + -lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info -lookupIdentInfo mo i = lookupIdent i (jments mo) lookupQIdentInfo :: ErrorMonad m => Grammar -> QIdent -> m Info -lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m +lookupQIdentInfo gr (m,c) = do + mi <- lookupModule gr m + lookupIdentInfo (m,mi) c lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term lookupResDef gr (m,c) diff --git a/src/compiler/api/GF/Infra/Option.hs b/src/compiler/api/GF/Infra/Option.hs index 373d2ac72..61a5e80a3 100644 --- a/src/compiler/api/GF/Infra/Option.hs +++ b/src/compiler/api/GF/Infra/Option.hs @@ -357,7 +357,7 @@ optDescr = Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) "Never recompile from source, if there is already .gfo file.", Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = RetainAll })) "Retain the source and well as the compiled grammar.", - Option [] ["resource"] (NoArg (set $ \o -> o { optRetainResource = RetainSource })) "Load the source grammar as a resource only.", + Option [] ["resource"] (NoArg (set $ \o -> o { optRetainResource = RetainSource })) "Load the source grammar as a resource to a precompiled PGF.", Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.", Option ['n'] ["name"] (ReqArg name "NAME") (unlines ["Use NAME as the name of the output. This is used in the output file names, ", diff --git a/src/compiler/api/GF/Infra/SIO.hs b/src/compiler/api/GF/Infra/SIO.hs index 397d7fa1f..e09181b3f 100644 --- a/src/compiler/api/GF/Infra/SIO.hs +++ b/src/compiler/api/GF/Infra/SIO.hs @@ -134,7 +134,7 @@ newStdGen = lift0 IO.newStdGen runInterruptibly = lift1 IO.runInterruptibly importGrammar readNGF pgf opts files = lift0 $ GF.importGrammar readNGF pgf opts files -importSource opts files = lift0 $ GF.importSource opts files +importSource opts mb_pgf files = lift0 $ GF.importSource opts mb_pgf files link opts pgf src = lift0 $ GF.link opts pgf src modifyPGF gr t = lift0 (PGFT.modifyPGF gr t) diff --git a/src/compiler/api/GF/Interactive.hs b/src/compiler/api/GF/Interactive.hs index f6be8795b..ed844ba1f 100644 --- a/src/compiler/api/GF/Interactive.hs +++ b/src/compiler/api/GF/Interactive.hs @@ -427,10 +427,10 @@ importInEnv :: ReadNGF -> Options -> [FilePath] -> ShellM () importInEnv readNGF opts files = do (_,pgf0,mb_txnid) <- gets pgfenv case (flag optRetainResource opts,mb_txnid) of - (RetainAll,Nothing) -> do src <- lift $ importSource opts files + (RetainAll,Nothing) -> do src <- lift $ importSource opts Nothing 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 + (RetainSource,mb_txn) -> do src <- lift $ importSource opts pgf0 files modify $ \gfenv -> gfenv{pgfenv = (snd src,pgf0,mb_txn)} (RetainCompiled,Nothing) -> do pgf <- lift $ importPGF pgf0 modify $ \gfenv -> gfenv{pgfenv = (emptyGrammar,pgf,Nothing)} diff --git a/src/runtime/c/pgf/db.h b/src/runtime/c/pgf/db.h index 4106cca6a..760437d70 100644 --- a/src/runtime/c/pgf/db.h +++ b/src/runtime/c/pgf/db.h @@ -107,6 +107,7 @@ class PgfDB { PGF_INTERNAL_DECL static txn_t get_txn_id(); PGF_INTERNAL_DECL const char *get_file_path() { return filepath; }; + PGF_INTERNAL_DECL void set_file_path(const char *filepath) { this->filepath = strdup(filepath); }; template static ref malloc(size_t extra_bytes=0) { diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index c2c5bd9b7..72f73df20 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -58,6 +58,7 @@ PgfDB *pgf_read_pgf(const char* fpath, PgfRevision *revision, size_t pgf_size = ftell(in); fseek(in, 0, SEEK_SET); db = new PgfDB(NULL, 0, 0, pgf_size*7); + db->set_file_path(fpath); { DB_scope scope(db, WRITER_SCOPE); diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 7f1e0d7da..f99c828d3 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -19,6 +19,7 @@ module PGF2 (-- * PGF #if defined(__linux__) || defined(__APPLE__) writePGF_, #endif + pgfFilePath, -- * Abstract syntax AbsName,abstractName,globalFlag,abstractFlag, @@ -278,6 +279,9 @@ cookie_write cookie buf size = do fmap fromIntegral $ (callback :: Ptr Word8 -> Int -> IO Int) buf (fromIntegral size) #endif +pgfFilePath :: PGF -> FilePath +pgfFilePath p = unsafePerformIO (pgf_file_path (a_db p) >>= peekCString) + 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 1ee617640..26244dece 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -93,6 +93,8 @@ foreign import ccall pgf_write_pgf_cookie :: Ptr () -> FunPtr (Ptr () -> Ptr Wor foreign import ccall pgf_write_pgf_cookie :: Ptr () -> FunPtr (Ptr () -> Ptr Word8 -> CInt -> IO CInt) -> Ptr PgfDB -> Ptr PGF -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO () #endif +foreign import ccall pgf_file_path :: Ptr PgfDB -> IO CString + foreign import ccall "pgf_free_revision" pgf_free_revision_ :: Ptr PgfDB -> Ptr PGF -> IO () foreign import ccall "&pgf_free_revision" pgf_free_revision :: FinalizerEnvPtr PgfDB PGF diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index b123a6b2c..8a89bb0c4 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -1285,11 +1285,7 @@ PGF_embed(PGFObject* self, PyObject *modname) py_embedding->grammar = self; Py_INCREF(self); const char *fpath = pgf_file_path(self->db); - if (fpath == NULL) { - py_embedding->grammar_path = Py_None; Py_INCREF(Py_None); - } else { - py_embedding->grammar_path = PyUnicode_FromString(fpath); - } + py_embedding->grammar_path = PyUnicode_FromString(fpath); if (module == NULL) { py_embedding->package_path = PyList_New(0);