now we can load PGF files as precompiled modules

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")
        ],

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 :: Options -> Maybe PGF -> [FilePath] -> IO (ModuleName,SourceGrammar)
-importSource opts files = fmap snd (batchCompile opts files)
+importSource opts mb_pgf files = fmap snd (batchCompile opts mb_pgf files)
 
 -- for different cf formats
 importCF opts files get convert = impCF

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 :: Options -> Maybe PGF -> [FilePath] -> IOE (UTCTime,(ModuleName,Grammar))
-batchCompile opts files = do
+batchCompile opts mb_pgf files = do
-  (gr,menv) <- foldM (compileModule opts) emptyCompileEnv files
+  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 :: Maybe PGF -> IOE CompileEnv
-emptyCompileEnv = (emptyGrammar,Map.empty)
+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)

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,7 +124,7 @@ getAllFiles opts ps env file = do
       return (name,st,t,isJust gfTime,imps,dropFileName file)
 --------------------------------------------------------------------------------
 
-findFile gfoDir ps name =
+findFile gfoDir ps env name =
   maybe noSource haveSource =<< getFilePath ps (gfFile name)
   where
     haveSource gfFile =
@@ -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." $$
+        noGFO =
-                               "searched in:" <+> vcat ps))
+          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
 

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 = Ident -> Maybe Term
-type StatusMap = Map.Map Ident StatusInfo
-
-type StatusInfo = Ident -> 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 <- lookupErr m' qualifs
-      f <- lookupIdent c m
+      maybe (notFound c) return (f c)
-      return $ f c
     QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
     QC (m',c) -> do
-      m <- lookupErr m' qualifs
+      f <- lookupErr m' qualifs
-      f <- lookupIdent c m
+      maybe (notFound c) return (f 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
+      case act c of
-        Just f -> return (f c)
+        Just t -> return t
-        _      -> case mapMaybe (Map.lookup c) opens of
+        _      -> case mapMaybe (\f -> f c) opens of
-                    [f]  -> return (f c)
+                    [t]  -> return t
                     []   -> alt c ("constant not found:" <+> c $$
                                    "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                    fs   -> case nub [f c | f <- fs]  of
+                    ts   -> case nub ts  of
-                              [tr]     -> return tr
+                              [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.
+                                             return t
-       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,
+info2status :: Maybe ModuleName -> Ident -> Info -> Term
-        -- 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
 info2status mq c i = case i of
-  AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
+  AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq c
-  ResValue _ _ -> maybe Con (curry QC) mq
+  ResValue _ _ -> maybe Con (curry QC) mq c
-  ResParam _ _ -> maybe Con (curry QC) mq
+  ResParam _ _ -> maybe Con (curry QC) mq c
-  AnyInd True m -> maybe Con (const (curry QC m)) mq
+  AnyInd True m -> maybe Con (const (curry QC m)) mq c
-  AnyInd False m -> maybe Cn (const (curry Q m)) mq
+  AnyInd False m -> maybe Cn (const (curry Q m)) mq c
-  _           -> maybe Cn (curry Q) mq
+  _           -> maybe Cn (curry Q) mq c
 
 tree2status :: OpenSpec -> Map.Map Ident Info -> StatusMap
-tree2status o = case o of
+tree2status o map = case o of
-  OSimple i   -> Map.mapWithKey (info2status (Just i))
+  OSimple i   -> flip Map.lookup (Map.mapWithKey (info2status (Just i)) map)
-  OQualif i j -> Map.mapWithKey (info2status (Just j))
+  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]
+      exts = [(o,modInfo2status o mi) | (m,mi) <- allExtends gr1 m, let o = OSimple m]
-  ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
+  ops <- mapM (openSpec2status gr1) (mopens mi)
-  let sts = map modInfo2status (exts++ops)
+  let sts = exts++ops
   return (if isModCnc mi
-            then (Map.empty,       reverse sts)  -- the module itself does not define any names
+            then (const Nothing,   reverse sts)  -- the module itself does not define any names
-            else (self2status m mi,reverse sts)) -- so the empty ident is not needed
+            else (self2status m mi,reverse sts))
 
-modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap)
+openSpec2status gr o =
-modInfo2status (o,mo) = (o,tree2status o (jments mo))
+  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 -> 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

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))

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 $

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
+    frontend = runPass Extend  "extending"  . extendModule cwd gr
-           <=< runPass Rebuild "" . rebuildModule cwd gr
+           <=< runPass Rebuild "rebuilding" . rebuildModule cwd gr
 
     -- Apply to complete modules
     middle   = runPass TypeCheck "type checking" . checkModule opts cwd gr

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) =

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)
@@ -92,7 +92,8 @@ data Grammar = MGrammar {
 -- | Modules
 type Module = (ModuleName, ModuleInfo)
 
-data ModuleInfo = ModInfo {
+data ModuleInfo
+ = ModInfo {
     mtype   :: ModuleType,
     mstatus :: ModuleStatus,
     mflags  :: Options,
@@ -104,6 +105,9 @@ data ModuleInfo = ModInfo {
     mseqs   :: Maybe (Seq.Seq [Symbol]),
     jments  :: Map.Map Ident Info
    }
+ | ModPGF {
+    mpgf :: PGF
+   }
 
 type SourceGrammar = Grammar
 type SourceModule = Module

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)

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, ",

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)

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)}

src/runtime/c/pgf/db.h

@@ -107,6 +107,7 @@ public:
     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<class A>
     static ref<A> malloc(size_t extra_bytes=0) {

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);

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 '{' $$

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

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);
-    }
 
     if (module == NULL) {
         py_embedding->package_path = PyList_New(0);