gfcc generation in gfc works for some grammars

src/GF/Devel/GFC.hs

@@ -2,6 +2,7 @@ module Main where
 
 import GF.Devel.Compile
 import GF.Devel.GrammarToGFCC
+import GF.Devel.UseIO
 ---import GF.Devel.PrGrammar ---
 
 import System
@@ -13,9 +14,11 @@ main = do
     "-help":[] -> putStrLn "usage: gfc (--make) FILES"
     "--make":fs -> do
       gr <- batchCompile fs
-      --- putStrLn $ prGrammar gr
-      writeFile "a.gfcc" $ prGrammar2gfcc gr
-      putStrLn "Wrote file a.gfcc."
+      let name = justModuleName (last fs)
+      let (abs,gc) = prGrammar2gfcc name gr
+      let target = abs ++ ".gfcc"
+      writeFile target gc
+      putStrLn $ "wrote file " ++ target
     _ -> do
       mapM_ batchCompile (map return xx)
       putStrLn "Done."

src/GF/Devel/GrammarToGFCC.hs

@@ -10,6 +10,7 @@ import qualified GF.Grammar.Macros as GM
 import qualified GF.Infra.Modules as M
 import qualified GF.Infra.Option as O
 
+import GF.Devel.ModDeps
 import GF.Infra.Ident
 import GF.Data.Operations
 import GF.Text.UTF8
@@ -20,11 +21,15 @@ import Debug.Trace ----
 
 -- the main function: generate GFCC from GF.
 
-prGrammar2gfcc :: SourceGrammar-> String
-prGrammar2gfcc = Pr.printTree . mkCanon2gfcc
+prGrammar2gfcc :: String -> SourceGrammar -> (String,String)
+prGrammar2gfcc cnc gr = (abs, Pr.printTree gc) where
+  (abs,gc) = mkCanon2gfcc cnc gr 
 
-mkCanon2gfcc :: SourceGrammar -> C.Grammar
-mkCanon2gfcc = canon2gfcc . reorder . utf8Conv . canon2canon
+mkCanon2gfcc :: String -> SourceGrammar -> (String,C.Grammar)
+mkCanon2gfcc cnc gr = 
+  (prIdent abs, (canon2gfcc . reorder abs . utf8Conv . canon2canon abs) gr)
+  where
+    abs = err error id $ M.abstractOfConcrete gr (identC cnc)
 
 -- This is needed to reorganize the grammar. GFCC has its own back-end optimization.
 -- But we need to have the canonical order in tables, created by valOpt
@@ -102,15 +107,14 @@ mkTerm tr = case tr of
 
 -- return just one module per language
 
-reorder :: SourceGrammar -> SourceGrammar
-reorder cg = M.MGrammar $ 
+reorder :: Ident -> SourceGrammar -> SourceGrammar
+reorder abs cg = M.MGrammar $ 
     (abs, M.ModMod $ 
           M.Module M.MTAbstract M.MSComplete [] [] [] adefs):
       [(c, M.ModMod $ 
           M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js)) 
             | (c,js) <- cncs] 
      where
-       abs = maybe (error "no abstract") id $ M.greatestAbstract cg
        mos = M.allModMod cg
        adefs = 
          sorted2tree $ sortBy (\ (f,_) (g,_) -> compare f g) 
@@ -125,9 +129,8 @@ reorder cg = M.MGrammar $
               finfo <- tree2list (M.jments mo)]
 
 -- one grammar per language - needed for symtab generation
-repartition :: SourceGrammar -> [SourceGrammar]
-repartition cg = [M.partOfGrammar cg (lang,mo) | 
-  let abs = maybe (error "no abstract") id $ M.greatestAbstract cg,
+repartition :: Ident -> SourceGrammar -> [SourceGrammar]
+repartition abs cg = [M.partOfGrammar cg (lang,mo) | 
   let mos = M.allModMod cg,
   lang <- M.allConcretes cg abs,
   let mo = errVal 
@@ -151,11 +154,11 @@ utf8Conv = M.MGrammar . map toUTF8 . M.modules where
 
 -- translate tables and records to arrays, parameters and labels to indices
 
-canon2canon :: SourceGrammar -> SourceGrammar
-canon2canon = recollect . map cl2cl . repartition where
+canon2canon :: Ident -> SourceGrammar -> SourceGrammar
+canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs where
   recollect = 
     M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
-  cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where
+  cl2cl cg = M.MGrammar $ map c2c $ M.modules cg where
     c2c (c,m) = case m of
       M.ModMod mo@(M.Module _ _ _ _ _ js) ->
         (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js)
@@ -175,6 +178,15 @@ canon2canon = recollect . map cl2cl . repartition where
      (unlines [A.prt t | 
        (t,_) <- Map.toList typs])
 
+
+purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
+purgeGrammar abstr gr = (M.MGrammar . filter complete . purge . M.modules) gr where
+  purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
+  needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
+  acncs = abstr : M.allConcretes gr abstr
+  isSingle = True
+  complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon
+
 type ParamEnv =
   (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
    Map.Map Term Integer,                   -- untyped terms to values

src/GF/Devel/ModDeps.hs

@@ -0,0 +1,153 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ModDeps
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- Check correctness of module dependencies. Incomplete.
+--
+-- AR 13\/5\/2003
+-----------------------------------------------------------------------------
+
+module GF.Devel.ModDeps (mkSourceGrammar,
+		moduleDeps,
+		openInterfaces,
+		requiredCanModules
+	       ) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Devel.PrGrammar
+import GF.Compile.Update
+import GF.Grammar.Lookup
+import GF.Infra.Modules
+
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List
+
+-- | to check uniqueness of module names and import names, the
+-- appropriateness of import and extend types,
+-- to build a dependency graph of modules, and to sort them topologically
+mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar
+mkSourceGrammar ms = do
+  let ns = map fst ms
+  checkUniqueErr ns
+  mapM (checkUniqueImportNames ns . snd) ms
+  deps    <- moduleDeps ms
+  deplist <- either 
+               return 
+               (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ 
+               topoTest deps
+  return $ MGrammar [(m, maybe undefined id $ lookup m ms)  | IdentM m _ <- deplist]
+
+checkUniqueErr ::  (Show i, Eq i) => [i] -> Err ()
+checkUniqueErr ms = do
+  let msg = checkUnique ms
+  if null msg then return () else Bad $ unlines msg
+
+-- | check that import names don't clash with module names
+checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
+checkUniqueImportNames ns mo = case mo of
+  ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
+  _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo
+ where
+
+  test ms = testErr (all (`notElem` ns) ms)
+                    ("import names clashing with module names among" +++ 
+                       unwords (map prt ms))
+
+type Dependencies = [(IdentM Ident,[IdentM Ident])]
+
+-- | to decide what modules immediately depend on what, and check if the
+-- dependencies are appropriate
+moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies
+moduleDeps ms = mapM deps ms where
+  deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
+    ModMod m -> case mtype m of
+      MTConcrete a -> do
+        aty <- lookupModuleType gr a
+        testErr (aty == MTAbstract) "the of-module is not an abstract syntax" 
+        chDep (IdentM c (MTConcrete a)) 
+              (extends m) (MTConcrete a) (opens m) MTResource
+      t -> chDep (IdentM c t) (extends m) t (opens m) t
+
+  chDep it es ety os oty = do
+    ests <- mapM (lookupModuleType gr) es
+    testErr (all (compatMType ety) ests) "inappropriate extension module type" 
+----    osts <- mapM (lookupModuleType gr . openedModule) os
+----    testErr (all (compatOType oty) osts) "inappropriate open module type"
+    let ab = case it of
+               IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
+               _ -> [] ---- 
+    return (it, ab ++
+                [IdentM e ety | e <- es] ++ 
+                [IdentM (openedModule o) oty | o <- os])
+
+  -- check for superficial compatibility, not submodule relation etc: what can be extended
+  compatMType mt0 mt = case (mt0,mt) of
+    (MTResource,   MTConcrete _) -> True
+    (MTInstance _, MTConcrete _) -> True
+    (MTInterface,  MTAbstract)   -> True
+    (MTConcrete _, MTConcrete _) -> True
+    (MTInstance _, MTInstance _) -> True
+    (MTReuse _, MTReuse _) -> True
+    (MTInstance _, MTResource) -> True
+    (MTResource, MTInstance _) -> True
+    ---- some more?
+    _ -> mt0 == mt
+  -- in the same way; this defines what can be opened
+  compatOType mt0 mt = case mt0 of
+    MTAbstract     -> mt == MTAbstract
+    MTTransfer _ _ -> mt == MTAbstract
+    _ -> case mt of
+      MTResource -> True
+      MTReuse _ -> True
+      MTInterface -> True
+      MTInstance _ -> True
+      _ -> False      
+
+  gr = MGrammar ms --- hack
+
+openInterfaces :: Dependencies -> Ident -> Err [Ident]
+openInterfaces ds m = do
+  let deps = [(i,ds) | (IdentM i _,ds) <- ds]
+  let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is]
+  let mods = iterFix (concatMap more) (more (m,undefined))
+  return $ [i | (i,MTInterface) <- mods]
+
+-- | this function finds out what modules are really needed in the canonical gr.
+-- its argument is typically a concrete module name
+requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i]
+requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
+  exts = allExtends gr c
+  ops  = if isSingle 
+         then map fst (modules gr) 
+         else iterFix (concatMap more) $ exts
+  more i = errVal [] $ do
+    m <- lookupModMod gr i
+    return $ extends m ++ [o | o <- map openedModule (opens m)]
+  notReuse i = errVal True $ do
+    m <- lookupModMod gr i
+    return $ isModRes m -- to exclude reused Cnc and Abs from required
+
+
+{-
+-- to test
+exampleDeps = [
+  (ir "Nat",[ii "Gen", ir "Adj"]),
+  (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]),
+  (ir "Nou",[ii "Cas"])
+  ]
+
+ii s = IdentM (IC s) MTInterface
+ir s = IdentM (IC s) MTResource
+-}
+