now we can load PGF files as precompiled modules

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
 

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"]
+                                             return t
 
-        -- 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
+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))
 
-modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap)
-modInfo2status (o,mo) = (o,tree2status o (jments mo))
+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 -> 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))