diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs index b2b5148ff..bfcae3cf3 100644 --- a/src/GF/Canon/CanonToGFCC.hs +++ b/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 - P x@(Arg (A cat i)) lab -> - P x . mkLab $ maybe (prtTrace tr $ 66664) snd $ - Map.lookup (cat,[lab]) labels - P p lab2 -> case getLab p of - Ok (cat,lab1) -> P (r2r p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ - 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 + + r2r tr@(P p _) = case getLab tr of + Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ + Map.lookup (cat,labs) labels + _ -> K (KS (A.prt tr +++ prtTrace tr "66665")) + + -- this goes recursively into tables (ignored) and records (accumulated) 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 = diff --git a/src/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs index ae34dc249..ae9097c44 100644 --- a/src/GF/Canon/GFC.hs +++ b/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 diff --git a/src/GF/Canon/GFCC/Test.gf b/src/GF/Canon/GFCC/Test.gf index 86f4adbdf..6cbbd367c 100644 --- a/src/GF/Canon/GFCC/Test.gf +++ b/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} ; -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 ; n = Sg ; 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 Dets no = {s = \\c => no.s ! NF Pl c ; a = {n = Pl ; p = P3}} ; +lincat NP = {s : Case => Str ; n : Number ; p : Person} ; +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.n np.p ++ ob.s ! Part} ; +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 Mina = {s = table Case ["minä" ; "minua"] ; n = Sg ; p = P1} ; +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" ; diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index 1805a6cff..ebdfe1054 100644 --- a/src/GF/Compile/Compile.hs +++ b/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 () diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs index 8ca328032..089773824 100644 --- a/src/GF/Compile/GrammarToCanon.hs +++ b/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 diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index 374c79d01..715cd796a 100644 --- a/src/GF/Compile/Optimize.hs +++ b/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 diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index 07ddaa97a..aabb11e34 100644 --- a/src/GF/Compile/ShellState.hs +++ b/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) = diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index 0cff03328..edbddbd3c 100644 --- a/src/GF/Infra/Modules.hs +++ b/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