msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

bug fixes in multigrammar handling and GFCC generation

Browse Source
This commit is contained in:
aarne
2006-09-16 18:42:46 +00:00
parent 55c7be9a8e
commit d4e1e2d192
8 changed files with 82 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

53
src/GF/Canon/CanonToGFCC.hs
View File

@@ -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 =

21
src/GF/Canon/GFC.hs
View File

@@ -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

27
src/GF/Canon/GFCC/Test.gf
View File

@@ -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" ;

4
src/GF/Compile/Compile.hs
View File

@@ -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 ()

3
src/GF/Compile/GrammarToCanon.hs
View File

@@ -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

4
src/GF/Compile/Optimize.hs
View File

@@ -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

10
src/GF/Compile/ShellState.hs
View File

@@ -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) =

5
src/GF/Infra/Modules.hs
View File

@@ -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