found and temporarily solved the bug in LangGer gfcc generation

4 files changed, 51 insertions, 21 deletions

diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs
index 79c45f337..213f5d304 100644
--- a/src/GF/Devel/GrammarToGFCC.hs
+++ b/src/GF/Devel/GrammarToGFCC.hs
@@ -177,16 +177,20 @@ reorder abs cg = M.MGrammar $
               finfo <- tree2list (M.jments mo)]
        predefADefs = 
          [(IC c, AbsCat (Yes []) Nope) | c <- ["Float","Int","String"]]
-       aflags = nubFlags $ concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
+       aflags = nubFlags $ 
+         concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
 
        cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs]
-       concr la = (nubFlags (concat flags), sortIds (predefCDefs ++ concat jments)) where 
-         (flags,jments) = unzip $ cdata la
-       cdata la = [(M.flags mo, tree2list (M.jments mo)) | 
-                    (i,mo) <- mos, M.isModCnc mo, elem i (M.allExtends cg la)]
-       predefCDefs = 
-         [(IC c, CncCat (Yes GM.defLinType) Nope Nope) | ---- lindef,printname 
-                                            c <- ["Float","Int","String"]]
+       concr la = (nubFlags flags, 
+                   sortIds (predefCDefs ++ jments)) where 
+         jments = Look.allOrigInfos cg la
+         flags  = concat [M.flags mo | 
+                     (i,mo) <- mos, M.isModCnc mo, 
+                     Just r <- [lookup i (M.allExtendSpecs cg la)]]
+
+         predefCDefs = [(IC c, CncCat (Yes GM.defLinType) Nope Nope) | 
+                       ---- lindef,printname 
+                         c <- ["Float","Int","String"]]
 
        sortIds = sortBy (\ (f,_) (g,_) -> compare f g) 
        nubFlags = nubBy (\ (Opt (f,_)) (Opt (g,_)) -> f == g)
@@ -301,7 +305,9 @@ paramValues cgr = (labels,untyps,typs) where
     Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
   lincats = 
     [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Int", "Float", "String"]] ++
-    [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
+    reverse ---- TODO: really those lincats that are reached
+            ---- reverse is enough to expel overshadowed ones... 
+      [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
   labels = Map.fromList $ concat 
     [((cat,[lab]),(typ,i)): 
       [((cat,[lab,lab2]),(ty,j)) | 
@@ -400,13 +406,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
 
    valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps
     where
-      tryPerm tr = case tr of
-{- obsolete ----
-        R rs -> case Map.lookup (R rs) untyps of
-	  Just v -> EInt v
-          _ -> valNumFV $ tryVar tr
--}
-        _ -> valNumFV $ tryVar tr
+      tryPerm tr = valNumFV $ tryVar tr
       tryVar tr = case GM.appForm tr of
         (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryVar ts)]
         (FV ts,_) -> ts
diff --git a/src/GF/GFCC/Linearize.hs b/src/GF/GFCC/Linearize.hs
index 572b8fe08..b7b419f7d 100644
--- a/src/GF/GFCC/Linearize.hs
+++ b/src/GF/GFCC/Linearize.hs
@@ -6,6 +6,8 @@ import GF.GFCC.AbsGFCC
 import Data.Map
 import Data.List
 
+import Debug.Trace
+
 -- linearization and computation of concrete GFCC Terms
 
 linearize :: GFCC -> CId -> Exp -> String
@@ -53,7 +55,7 @@ compute mcfg lang args = comp where
   look = lookOper mcfg lang
 
   idx xs i = if i > length xs - 1 
-    then error 
+    then trace 
          ("too large " ++ show i ++ " for\n" ++ unlines (lmap prt xs) ++ "\n") TM 
     else xs !! i 
 
@@ -71,7 +73,7 @@ compute mcfg lang args = comp where
     C i    -> i
     RP p _ -> getIndex p ---- DEPREC
     TM     -> 0  -- default value for parameter
-    _ -> error ("ERROR in grammar compiler: index from " ++ show t) 0
+    _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 666
 
   getField t i = case t of
     R rs   -> idx rs i
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index a0d0d1cea..01f6c20a1 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -24,6 +24,7 @@ module GF.Grammar.Lookup (
 	       lookupFirstTag, 
                lookupValueIndex,
                lookupIndexValue,
+               allOrigInfos,
 	       allParamValues, 
 	       lookupAbsDef, 
 	       lookupLincat, 
@@ -121,6 +122,17 @@ lookupOverload gr m c = do
           _   -> Bad $ prt c +++ "is not an overloaded operation"
       _ -> Bad $ prt m +++ "is not a resource"
 
+lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info
+lookupOrigInfo gr m c = do
+    mi   <- lookupModule gr m
+    case mi of
+      ModMod mo -> do
+        info <- lookupIdentInfo mo c
+        case info of
+          AnyInd _ n  -> lookupOrigInfo gr n c
+          i   -> return i
+      _ -> Bad $ prt m +++ "is not run-time module"
+
 lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues)
 lookupParams gr = look True where 
   look isTop m c = do
@@ -169,6 +181,14 @@ lookupIndexValue gr ty i = do
     then return $ ts !! i
     else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty
 
+allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
+allOrigInfos gr m = errVal [] $ do
+  mi <- lookupModule gr m
+  case mi of
+    ModMod mo -> return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]]
+ where
+   look = lookupOrigInfo gr m
+
 allParamValues :: SourceGrammar -> Type -> Err [Term]
 allParamValues cnc ptyp = case ptyp of
      App (Q (IC "Predef") (IC "Ints")) (EInt n) -> 
diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index b0fe1b0ba..4d50608c6 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -28,7 +28,8 @@ module GF.Infra.Modules (
 		oSimple, oQualif,
 		ModuleStatus(..),
 		openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar,
-		allExtends, allExtendsPlus, allExtensions, searchPathModule, addModule,
+		allExtends, allExtendSpecs, allExtendsPlus, allExtensions, 
+                searchPathModule, addModule,
 		emptyMGrammar, emptyModInfo, emptyModule,
 		IdentM(..),
 		typeOfModule, abstractOfConcrete, abstractModOfConcrete,
@@ -216,8 +217,7 @@ partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
       ---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ----
       _ -> [i]
 
-
--- | all modules that a module extends, directly or indirectly
+-- | all modules that a module extends, directly or indirectly, without restricts
 allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
 allExtends gr i = case lookupModule gr i of
   Ok (ModMod m) -> case extends m of 
@@ -225,6 +225,14 @@ allExtends gr i = case lookupModule gr i of
     is -> i : concatMap (allExtends gr) is
   _ -> []
 
+-- | all modules that a module extends, directly or indirectly, with restricts
+allExtendSpecs :: (Show i,Ord i) => MGrammar i f a -> i -> [(i,MInclude i)]
+allExtendSpecs gr i = case lookupModule gr i of
+  Ok (ModMod m) -> case extend m of 
+    [] -> [(i,MIAll)]
+    is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
+  _ -> []
+
 -- | this plus that an instance extends its interface
 allExtendsPlus :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
 allExtendsPlus gr i = case lookupModule gr i of