From 0ce04f1a6e0237c3282be737ba2f2069e318100e Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Thu, 14 Aug 2008 20:25:52 +0000
Subject: [PATCH] forgiving names in concrete that are not in abstract, with a
 warning (no warning guaranteed if this is because restricted inheritance)

---
 src/GF/Compile/CheckGrammar.hs  | 21 ++++++++++++++++++---
 src/GF/Compile/GrammarToGFCC.hs |  6 +++++-
 2 files changed, 23 insertions(+), 4 deletions(-)

diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 0a8361d36..51dcab70b 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -184,10 +184,25 @@ checkAbsInfo st m mo (c,info) = do
 
 checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info)
 checkCompleteGrammar abs cnc = do
-  let js = jments cnc
-  let fs = tree2list $ jments abs
-  foldM checkOne js fs
+  let jsa = jments abs
+  let fsa = tree2list jsa
+  let jsc = jments cnc
+  let fsc = map fst $ filter (isCnc . snd) $ tree2list jsc
+
+  -- remove those lincat and lin in concrete that are not in abstract
+  let unkn = filter (not . flip isInBinTree jsa) fsc
+  jsc1 <- if (null unkn) then return jsc else do
+    checkWarn $ "WARNING: ignoring constants not in abstract:" +++ 
+                unwords (map prt unkn)
+    return $ filterBinTree (\f _ -> notElem f unkn) jsc 
+
+  -- check that all abstract constants are in concrete; build default lincats
+  foldM checkOne jsc1 fsa
  where
+   isCnc j = case j of
+     CncFun _ _ _ -> True
+     CncCat _ _ _ -> True
+     _ -> False
    checkOne js i@(c,info) = case info of
      AbsFun (Yes _) _ -> case lookupIdent c js of
        Ok _ -> return js
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index 2b4156bec..eee95f157 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -103,7 +103,9 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
                 ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id
       umkTerm = utf . mkTerm
       lins    = Map.fromAscList 
-        [(i2i f, umkTerm tr)  | (f,CncFun _ (Yes tr) _) <- js]
+        [(f', umkTerm tr)  | (f,CncFun _ (Yes tr) _) <- js, 
+            let f' = i2i f, exists f'] -- eliminating lins without fun 
+            -- needed even here because of restricted inheritance
       lincats = Map.fromAscList 
         [(i2i c, mkCType ty) | (c,CncCat (Yes ty) _ _) <- js]
       lindefs = Map.fromAscList 
@@ -115,6 +117,8 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
         [(i2i c, pars lang0 c) | (c,CncCat (Yes ty) _ _) <- js]
       fcfg = Nothing
 
+      exists f = Map.member f funs
+
 i2i :: Ident -> CId
 i2i = CId . ident2bs