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

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)

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,25 +124,28 @@ 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
          mb_gfoTime <- maybeIO $ getModificationTime (gf2gfo' gfoDir gfFile)
          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
 
         haveGFO gfoFile =
           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
 

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

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

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