bug fixes in multigrammar handling and GFCC generation

src/GF/Canon/CanonToGFCC.hs

@@ -32,6 +32,7 @@ import GF.UseGrammar.Linear (unoptimizeCanon)
 
 import GF.Infra.Ident
 import GF.Data.Operations
+import GF.Text.UTF8
 
 import Data.List
 import qualified Data.Map as Map
@@ -41,7 +42,7 @@ import Debug.Trace ----
 
 prCanon2gfcc :: CanonGrammar -> String
 prCanon2gfcc = 
-  Pr.printTree . canon2gfcc . reorder . canon2canon . normalize
+  Pr.printTree . canon2gfcc . reorder . utf8Conv . canon2canon . normalize
 
 -- 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
@@ -114,9 +115,23 @@ reorder cg = M.MGrammar $
             [(lang, concr lang) | lang <- M.allConcretes cg abs]
        concr la = sortBy (\ (f,_) (g,_) -> compare f g) 
             [finfo | 
-              (i,mo) <- mos, M.isModCnc mo, ----- TODO: separate langs 
+              (i,mo) <- mos, M.isModCnc mo, elem i (M.allExtends cg la),
               finfo <- tree2list (M.jments mo)]
 
+-- convert to UTF8 if not yet converted
+utf8Conv :: CanonGrammar -> CanonGrammar
+utf8Conv = M.MGrammar . map toUTF8 . M.modules where
+  toUTF8 mo = case mo of
+    (i, M.ModMod m) 
+      | hasFlagCanon (flagCanon "coding" "utf8") mo -> mo
+      | otherwise -> (i, M.ModMod $
+          m{ M.jments = 
+              mapTree (onSnd (mapInfoTerms (onTokens encodeUTF8))) (M.jments m),
+	     M.flags = setFlag "coding" "utf8" (M.flags m) }
+          )
+    _ -> mo
+ 
+
 -- translate tables and records to arrays, parameters and labels to indices
 
 canon2canon :: CanonGrammar -> CanonGrammar
@@ -165,7 +180,7 @@ paramValues cgr = (labels,untyps,typs) where
   lincats = [(cat,ls) | (_,(cat,CncCat (RecType ls) _ _)) <- jments]
   labels = Map.fromList $ concat 
     [((cat,[lab]),(typ,i)): 
-      [((cat,[lab,lab2]),(ty,j)) | 
+      [((cat,[lab2,lab]),(ty,j)) | 
         rs <- getRec typ, (Lbg lab2 ty,j) <- zip rs [0..]] 
       | 
         (cat,ls) <- lincats, (Lbg lab typ,i) <- zip ls [0..]]
@@ -180,8 +195,6 @@ paramValues cgr = (labels,untyps,typs) where
 term2term :: CanonGrammar -> ParamEnv -> Term -> Term
 term2term cgr env@(labels,untyps,typs) tr = case tr of
   Par _ _ -> mkValCase tr 
-----  Par c ps | any isVar ps -> mkCase c ps
-----  Par _ _  -> valNum tr
   R rs | any (isStr . trmAss) rs -> 
     R [Ass (mkLab i) (t2t t) | (i,Ass l t) <- zip [0..] rs, not (isLock l t)]
   R rs     -> valNum tr
@@ -193,22 +206,21 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
   _ -> composSafeOp t2t tr
  where
    t2t = term2term cgr env
-   -- Conj@0.s
+
-   r2r tr = case tr of
+   r2r tr@(P p _) = case getLab tr of
-     P x@(Arg (A cat i)) lab ->
+     Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ 
-        P x . mkLab $ maybe (prtTrace tr $ 66664) snd $ 
+          Map.lookup (cat,labs) labels
-          Map.lookup (cat,[lab]) labels
+     _ -> K (KS (A.prt tr +++ prtTrace tr "66665"))
-     P p lab2 -> case getLab p of
+
-       Ok (cat,lab1) -> P (r2r p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ 
+   -- this goes recursively into tables (ignored) and records (accumulated)
-          Map.lookup (cat,[lab1,lab2]) labels
-       _ -> P (t2t p) $ mkLab (prtTrace tr 66665)
-     _ -> tr ----
-     -- this goes recursively in tables
-     ---- TODO: also recursive in records to get longer lists of labels
    getLab tr = case tr of
-     P (Arg (A cat i)) lab1 -> return (cat,lab1)
+     Arg (A cat _) -> return (cat,[])
+     P p lab2 -> do
+       (cat,labs) <- getLab p
+       return (cat,lab2:labs) 
      S p _ -> getLab p
      _ -> Bad "getLab"
+
    mkLab k = L (IC ("_" ++ show k))
    valNum tr = maybe (K (KS (A.prt tr +++ prtTrace tr "66667"))) EInt $ 
      Map.lookup tr untyps
@@ -229,13 +241,11 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      _ -> valNum tr
 
    doVar :: Term -> STM [((CType,[Term]),(Term,Term))] Term
---   doVar tr = case tr of
---     P q@(Arg (A cat i)) lab -> do
    doVar tr = case getLab tr of
      Ok (cat, lab) -> do
        k <- readSTM >>= return . length
        let tr' = LI $ identC $ show k
-       let tyvs = case Map.lookup (cat,[lab]) labels of
+       let tyvs = case Map.lookup (cat,lab) labels of
              Just (ty,_) -> case Map.lookup ty typs of
                Just vs -> (ty,Map.keys vs)
                _ -> error $ A.prt ty
@@ -244,6 +254,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
        return tr'
      _ -> composOp doVar tr
 
+   --- this is mainly needed for parameter record projections
    comp t = errVal t $ Look.ccompute cgr [] t
 
    mkCase ((ty,vs),(x,p)) tr = 

src/GF/Canon/GFC.hs

@@ -21,7 +21,11 @@ module GF.Canon.GFC (Context,
 	    Printname,
             prPrintnamesGrammar,
 	    mapInfoTerms,
-	    setFlag
+	    setFlag,
+            flagIncomplete,
+            isIncompleteCanon,
+            hasFlagCanon,
+            flagCanon
 	   ) where
 
 import GF.Canon.AbsGFC
@@ -69,7 +73,20 @@ mapInfoTerms f i = case i of
 	 _ -> i
 
 setFlag :: String -> String -> [Flag] -> [Flag]
-setFlag n v fs = Flg (IC n) (IC v):[f | f@(Flg (IC n') _) <- fs, n' /= n]
+setFlag n v fs = flagCanon n v : [f | f@(Flg (IC n') _) <- fs, n' /= n]
+
+flagIncomplete :: Flag
+flagIncomplete = flagCanon "incomplete" "true"
+
+isIncompleteCanon :: CanonModule -> Bool
+isIncompleteCanon = hasFlagCanon flagIncomplete
+
+hasFlagCanon :: Flag -> CanonModule -> Bool
+hasFlagCanon f (_,M.ModMod mo) = elem f $ M.flags mo
+hasFlagCanon f _ = True ---- safe, useless 
+
+flagCanon :: String -> String -> Flag
+flagCanon f v = Flg (identC f) (identC v)
 
 -- for Ha-Jo 20/2/2005
 

src/GF/Canon/GFCC/Test.gf

@@ -18,26 +18,27 @@ param Case = Nom | Part ;
 param NForm = NF Number Case ;
 param VForm = VF Number Person ;
 
---lincat NP = {s : Case => Str ; n : Number ; p : Person} ;
-lincat NP = {s : Case => Str ; a : {n : Number ; p : Person}} ;
 lincat N  = Noun ; 
 lincat VP = Verb ; 
 
 oper Noun = {s : NForm => Str} ;
 oper Verb = {s : VForm => Str} ;
 
---lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.n np.p} ;
+lincat NP = {s : Case => Str ; n : Number ; p : Person} ;
-lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p} ;
+lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.n np.p} ;
-lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p ++ ob.s ! Part} ;
+lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.n np.p ++ ob.s ! Part} ;
---lin Det  no = {s = \\c => no.s ! NF Sg c ; n = Sg ; p = P3} ;
+lin Det  no = {s = \\c => no.s ! NF Sg c ; n = Sg ; p = P3} ;
---lin Dets no = {s = \\c => no.s ! NF Pl c ; n = Pl ; p = P3} ;
+lin Dets no = {s = \\c => no.s ! NF Pl c ; n = Pl ; p = P3} ;
-lin Det  no = {s = \\c => no.s ! NF Sg c ; a = {n = Sg ; p = P3}} ;
+lin Mina = {s = table Case ["minä" ; "minua"] ; n = Sg ; p = P1} ;
-lin Dets no = {s = \\c => no.s ! NF Pl c ; a = {n = Pl ; p = P3}} ;
+lin Te = {s = table Case ["te" ; "teitä"] ; n = Pl ; p = P2} ;
+--lincat NP = {s : Case => Str ; a : {n : Number ; p : Person}} ;
+--lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p} ;
+--lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p ++ ob.s ! Part} ;
+--lin Det  no = {s = \\c => no.s ! NF Sg c ; a = {n = Sg ; p = P3}} ;
+--lin Dets no = {s = \\c => no.s ! NF Pl c ; a = {n = Pl ; p = P3}} ;
+--lin Mina = {s = table Case ["minä" ; "minua"] ; a = {n = Sg ; p = P1}} ;
+--lin Te = {s = table Case ["te" ; "teitä"] ; a = {n = Pl ; p = P2}} ;
 
---lin Mina = {s = table Case ["minä" ; "minua"] ; n = Sg ; p = P1} ;
---lin Te = {s = table Case ["te" ; "teitä"] ; n = Pl ; p = P2} ;
-lin Mina = {s = table Case ["minä" ; "minua"] ; a = {n = Sg ; p = P1}} ;
-lin Te = {s = table Case ["te" ; "teitä"] ; a = {n = Pl ; p = P2}} ;
 
 lin Raha = mkN "raha" ;
 lin Paska = mkN "paska" ;

src/GF/Compile/Compile.hs

@@ -293,7 +293,7 @@ generateModuleCode opts path minfo@(name,info) = do
   let pname = prefixPathName path (prt name)
   minfo0     <- ioeErr $ redModInfo minfo
   let oopts  = addOptions opts (iOpts (flagsModule minfo))
-      optims = maybe "share" id $ getOptVal oopts useOptimizer
+      optims = maybe "all_subs" id $ getOptVal oopts useOptimizer
       optim  = takeWhile (/='_') optims
       subs   = drop 1 (dropWhile (/='_') optims) == "subs"
   minfo1     <- return $ 
@@ -316,7 +316,7 @@ generateModuleCode opts path minfo@(name,info) = do
   case info of
     ModMod m | emitsGFR m && emit && nomulti -> do
       let rminfo = if isCompilable info then minfo 
-                   else (name,emptyModInfo) 
+                   else (name, ModMod emptyModule) 
       let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo]))
       putp ("  wrote file" +++ file) $ ioeIO $ writeFile file out
     _ -> return ()

src/GF/Compile/GrammarToCanon.hs

@@ -73,7 +73,8 @@ redModInfo (c,info) = do
       let defs0 = concat defss
       let lgh = length defs0
       defs  <- return $ sorted2tree $ defs0  -- sorted, but reduced
-      let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags
+      let flags1 = if isIncompl then C.flagIncomplete : flags else flags
+      let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags1
       return $ ModMod $ Module mt MSComplete flags' e os defs
   return (c',info')
  where

src/GF/Compile/Optimize.hs

@@ -50,7 +50,7 @@ optimizeModule opts ms mo@(_,mi) = case mi of
   _ -> evalModule oopts ms mo
  where
    oopts = addOptions opts (iOpts (flagsModule mo))
-   optim = maybe "none" id $ getOptVal oopts useOptimizer
+   optim = maybe "all" id $ getOptVal oopts useOptimizer
 
 evalModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> 
                Err (Ident,SourceModInfo)
@@ -92,7 +92,7 @@ evalResInfo oopts gr (c,info) = case info of
  where
    comp = if optres then computeConcrete gr else computeConcreteRec gr
    eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
-   optim = maybe "none" id $ getOptVal oopts useOptimizer
+   optim = maybe "all" id $ getOptVal oopts useOptimizer
    optres = case optim of
      "noexpand" -> False
      _ -> True

src/GF/Compile/ShellState.hs

@@ -85,7 +85,7 @@ type Treebank = Map.Map String [String] -- string, trees
 actualConcretes :: ShellState -> [((Ident,Ident),Bool)]
 actualConcretes sh = nub [((c,c),b) | 
   Just a <- [abstract sh],
-  c <- concretesOfAbstract sh a,
+  ((c,_),_) <- concretes sh, ----concretesOfAbstract sh a,
   let b = True -----
   ]
 
@@ -233,7 +233,10 @@ updateShellState opts ign mcnc sh ((_,sgr,gr),rts) = do
   let oldConcrs = map (snd . fst) (concretes sh)
       newConcrs = maybe [] (M.allConcretes gr) abstr0
       toRetain (c,v) = notElem c newConcrs
-  let concrs = nub $ newConcrs ++ oldConcrs
+  let complete m = case M.lookupModule gr m of
+        Ok mo -> not $ isIncompleteCanon (m,mo)
+        _ -> False
+  let concrs = filter complete $ nub $ newConcrs ++ oldConcrs
       concr0 = ifNull Nothing (return . head) concrs
       notInrts f = notElem f $ map fst rts
       subcgr = unSubelimCanon cgr
@@ -317,7 +320,7 @@ purgeShellState sh = ShSt {
   abstract   = abstr,
   concrete   = concrete sh,
   concretes  = concrs,
-  canModules = M.MGrammar $ purge $ M.modules $ canModules sh,
+  canModules = M.MGrammar $ filter complete $ purge $ M.modules $ canModules sh,
   srcModules = M.emptyMGrammar,
   cfs        = cfs sh,
   abstracts  = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr,
@@ -341,6 +344,7 @@ purgeShellState sh = ShSt {
    needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs
    purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
    acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh)
+   complete = not . isIncompleteCanon
 
 changeMain :: Maybe Ident -> ShellState -> Err ShellState
 changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs) = 

src/GF/Infra/Modules.hs

@@ -22,7 +22,7 @@ module GF.Infra.Modules (
 		MGrammar(..), ModInfo(..), Module(..), ModuleType(..),
 		MReuseType(..), MInclude (..),
 		extends, isInherited,inheritAll, 
-                updateMGrammar, updateModule, replaceJudgements,
+                updateMGrammar, updateModule, replaceJudgements, addFlag,
 		addOpenQualif, flagsModule, allFlags, mapModules,
 		MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
 		oSimple, oQualif,
@@ -125,6 +125,9 @@ addOpenQualif :: i -> i -> Module i f t -> Module i f t
 addOpenQualif i j (Module mt ms fs me ops js) = 
   Module mt ms fs me (oQualif i j : ops) js
 
+addFlag :: f -> Module i f t -> Module i f t
+addFlag f mo = mo {flags = f : flags mo} 
+
 flagsModule :: (i,ModInfo i f a) -> [f]
 flagsModule (_,mi) = case mi of
   ModMod m -> flags m