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

gf works with the new gfcc format

Browse Source
This commit is contained in:
aarne
2007-10-05 12:54:29 +00:00
parent 945a49214b
commit 48623470cd
12 changed files with 118 additions and 185 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -19,8 +19,12 @@ import GF.Canon.AbsGFC
import qualified GF.Canon.GFC as GFC import qualified GF.Canon.GFC as GFC
import qualified GF.Canon.Look as Look import qualified GF.Canon.Look as Look
import qualified GF.Canon.Subexpressions as Sub import qualified GF.Canon.Subexpressions as Sub
import qualified GF.Canon.GFCC.AbsGFCC as C
import qualified GF.Canon.GFCC.PrintGFCC as Pr import qualified GF.GFCC.Macros as CM
import qualified GF.GFCC.AbsGFCC as C
import qualified GF.GFCC.DataGFCC as D
import GF.GFCC.OptimizeGFCC
import GF.Canon.GFC import GF.Canon.GFC
import GF.Canon.Share import GF.Canon.Share
import qualified GF.Grammar.Abstract as A import qualified GF.Grammar.Abstract as A
@@ -42,56 +46,71 @@ import Debug.Trace ----
-- the main function: generate GFCC from GFCM. -- the main function: generate GFCC from GFCM.
prCanon2gfcc :: CanonGrammar -> String prCanon2gfcc :: CanonGrammar -> String
prCanon2gfcc = Pr.printTree . mkCanon2gfcc prCanon2gfcc = D.printGFCC . mkCanon2gfcc
-- this variant makes utf8 conversion; used in back ends -- this variant makes utf8 conversion; used in back ends
mkCanon2gfcc :: CanonGrammar -> C.Grammar mkCanon2gfcc :: CanonGrammar -> D.GFCC
mkCanon2gfcc = canon2gfcc . reorder . utf8Conv . canon2canon . normalize mkCanon2gfcc =
-- canon2gfcc . reorder abs . utf8Conv . canon2canon abs
optGFCC . canon2gfcc . reorder . utf8Conv . canon2canon . normalize
-- this variant makes no utf8 conversion; used in ShellState -- this variant makes no utf8 conversion; used in ShellState
mkCanon2gfccNoUTF8 :: CanonGrammar -> C.Grammar mkCanon2gfccNoUTF8 :: CanonGrammar -> D.GFCC
mkCanon2gfccNoUTF8 = canon2gfcc . reorder . canon2canon . normalize mkCanon2gfccNoUTF8 = optGFCC . canon2gfcc . reorder . canon2canon . normalize
-- This is needed to reorganize the grammar. GFCC has its own back-end optimization. -- 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 -- But we need to have the canonical order in tables, created by valOpt
normalize :: CanonGrammar -> CanonGrammar normalize :: CanonGrammar -> CanonGrammar
normalize = share . unoptimizeCanon . Sub.unSubelimCanon where normalize = share . unoptimizeCanon . Sub.unSubelimCanon where
share = M.MGrammar . map (shareModule valOpt) . M.modules --- allOpt share = M.MGrammar . map (shareModule valOpt) . M.modules --- allOpt
-- Generate GFCC from GFCM. -- Generate GFCC from GFCM.
-- this assumes a grammar translated by canon2canon -- this assumes a grammar normalized and transformed by canon2canon
canon2gfcc :: CanonGrammar -> C.Grammar canon2gfcc :: CanonGrammar -> D.GFCC
canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where D.GFCC an cns abs cncs
cs = map (i2i . fst) cms where
adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) | an = (i2i a)
(f,GFC.AbsFun ty _) <- tree2list (M.jments abm), let f' = i2i f] cns = map (i2i . fst) cms
cncs = [C.Cnc (i2i lang) (concr m) | (lang,M.ModMod m) <- cms] abs = D.Abstr aflags funs cats catfuns
concr mo = cats mo ++ lindefs mo ++ aflags = Map.fromAscList [] ---- flags
optConcrete lfuns = [(f', (mkType ty,CM.primNotion)) | ---- defs
[C.Lin (i2i f) (mkTerm tr) | (f,GFC.AbsFun ty _) <- tree2list (M.jments abm), let f' = i2i f]
(f,GFC.CncFun _ _ tr _) <- tree2list (M.jments mo)] funs = Map.fromAscList lfuns
cats mo = [C.Lin (i2ic c) (mkCType ty) | lcats = [(i2i c,[]) | ---- context
(c,GFC.CncCat ty _ _) <- tree2list (M.jments mo)] (c,GFC.AbsCat _ _) <- tree2list (M.jments abm)]
lindefs mo = [C.Lin (i2id c) (mkTerm tr) | cats = Map.fromAscList lcats
(c,GFC.CncCat _ tr _) <- tree2list (M.jments mo)] catfuns = Map.fromAscList
[(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
cncs = Map.fromList [mkConcr (i2i lang) mo | (lang,M.ModMod mo) <- cms]
mkConcr lang mo = (lang,D.Concr flags lins opers lincats lindefs printnames)
where
flags = Map.fromAscList [] ---- flags
opers = Map.fromAscList [] -- opers will be created as optimization
lins = Map.fromAscList
[(i2i f, mkTerm tr) | (f,GFC.CncFun _ _ tr _) <- tree2list (M.jments mo)]
lincats = Map.fromAscList
[(i2i c, mkCType ty) | (c,GFC.CncCat ty _ _) <- tree2list (M.jments mo)]
lindefs = Map.fromAscList
[(i2i c, mkTerm tr) | (c,GFC.CncCat _ tr _) <- tree2list (M.jments mo)]
printnames = Map.fromAscList [] ---- printnames
i2i :: Ident -> C.CId i2i :: Ident -> C.CId
i2i (IC c) = C.CId c i2i (IC c) = C.CId c
i2ic (IC c) = C.CId ("__" ++ c) -- for lincat of category symbols
i2id (IC c) = C.CId ("_d" ++ c) -- for lindef of category symbols
mkType :: A.Type -> C.Type mkType :: A.Type -> C.Type
mkType t = case GM.catSkeleton t of mkType t = case GM.catSkeleton t of
Ok (cs,c) -> C.Typ (map (i2i . snd) cs) (i2i $ snd c) Ok (cs,c) -> CM.cftype (map (i2i . snd) cs) (i2i $ snd c)
mkCType :: CType -> C.Term mkCType :: CType -> C.Term
mkCType t = case t of mkCType t = case t of
TInts i -> C.C $ fromInteger i TInts i -> C.C $ fromInteger i
-- record parameter alias - created in gfc preprocessing -- record parameter alias - created in gfc preprocessing
RecType [Lbg (L (IC "_")) i, Lbg (L (IC "__")) t] -> C.RP (mkCType i) (mkCType t) RecType [Lbg (L (IC "_")) i, Lbg (L (IC "__")) t] -> C.RP (mkCType i) (mkCType t)
RecType rs -> C.R [mkCType t | Lbg _ t <- rs] RecType rs -> C.R [mkCType t | Lbg _ t <- rs]
Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt
TStr -> C.S [] TStr -> C.S []
where where
@@ -109,9 +128,6 @@ mkTerm tr = case tr of
R rs -> C.R [mkTerm t | Ass _ t <- rs] R rs -> C.R [mkTerm t | Ass _ t <- rs]
P t l -> C.P (mkTerm t) (C.C (mkLab l)) P t l -> C.P (mkTerm t) (C.C (mkLab l))
LI x -> C.BV $ i2i x
T _ [Cas [PV x] t] -> C.L (i2i x) (mkTerm t)
T _ cs -> error $ "improper optimization for gfcc in" +++ A.prt tr T _ cs -> error $ "improper optimization for gfcc in" +++ A.prt tr
V _ cs -> C.R [mkTerm t | t <- cs] V _ cs -> C.R [mkTerm t | t <- cs]
S t p -> C.P (mkTerm t) (mkTerm p) S t p -> C.P (mkTerm t) (mkTerm p)
@@ -401,102 +417,3 @@ unlockTyp = filter notlock where
prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
-- back-end optimization:
-- suffix analysis followed by common subexpression elimination
optConcrete :: [C.CncDef] -> [C.CncDef]
optConcrete defs = subex
[C.Lin f (optTerm t) | C.Lin f t <- defs]
-- analyse word form lists into prefix + suffixes
-- suffix sets can later be shared by subex elim
optTerm :: C.Term -> C.Term
optTerm tr = case tr of
C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts]
C.R ts -> C.R $ map optTerm ts
C.P t v -> C.P (optTerm t) v
C.L x t -> C.L x (optTerm t)
_ -> tr
where
optToks ss = prf : suffs where
prf = pref (head ss) (tail ss)
suffs = map (drop (length prf)) ss
pref cand ss = case ss of
s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss
_ -> cand
isK t = case t of
C.K (C.KS _) -> True
_ -> False
mkSuff ("":ws) = C.R (map (C.K . C.KS) ws)
mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws))
-- common subexpression elimination; see ./Subexpression.hs for the idea
subex :: [C.CncDef] -> [C.CncDef]
subex js = errVal js $ do
(tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0)
return $ addSubexpConsts tree js
type TermList = Map.Map C.Term (Int,Int) -- number of occs, id
type TermM a = STM (TermList,Int) a
addSubexpConsts :: TermList -> [C.CncDef] -> [C.CncDef]
addSubexpConsts tree lins =
let opers = sortBy (\ (C.Lin f _) (C.Lin g _) -> compare f g)
[C.Lin (fid id) trm | (trm,(_,id)) <- list]
in map mkOne $ opers ++ lins
where
mkOne (C.Lin f trm) = (C.Lin f (recomp f trm))
recomp f t = case Map.lookup t tree of
Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself
_ -> case t of
C.R ts -> C.R $ map (recomp f) ts
C.S ts -> C.S $ map (recomp f) ts
C.W s t -> C.W s (recomp f t)
C.P t p -> C.P (recomp f t) (recomp f p)
C.RP t p -> C.RP (recomp f t) (recomp f p)
C.L x t -> C.L x (recomp f t)
_ -> t
fid n = C.CId $ "_" ++ show n
list = Map.toList tree
getSubtermsMod :: [C.CncDef] -> TermM TermList
getSubtermsMod js = do
mapM (getInfo collectSubterms) js
(tree0,_) <- readSTM
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getInfo get (C.Lin f trm) = do
get trm
return ()
collectSubterms :: C.Term -> TermM ()
collectSubterms t = case t of
C.R ts -> do
mapM collectSubterms ts
add t
C.RP u v -> do
collectSubterms v
add t
C.S ts -> do
mapM collectSubterms ts
add t
C.W s u -> do
collectSubterms u
add t
C.P p u -> do
collectSubterms p
collectSubterms u
add t
_ -> return ()
where
add t = do
(ts,i) <- readSTM
let
((count,id),next) = case Map.lookup t ts of
Just (nu,id) -> ((nu+1,id), i)
_ -> ((1, i ), i+1)
writeSTM (Map.insert t (count,id) ts, next)

39
src/GF/Canon/CanonToJS.hs
View File

@@ -5,13 +5,16 @@ import GF.Canon.CanonToGFCC
import GF.Canon.Look import GF.Canon.Look
import GF.Data.ErrM import GF.Data.ErrM
import GF.Infra.Option import GF.Infra.Option
import qualified GF.Canon.GFCC.AbsGFCC as C import qualified GF.GFCC.Macros as M
import qualified GF.GFCC.DataGFCC as D
import qualified GF.GFCC.AbsGFCC as C
import qualified GF.JavaScript.AbsJS as JS import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS import qualified GF.JavaScript.PrintJS as JS
import Control.Monad (mplus) import Control.Monad (mplus)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
prCanon2js :: Options -> CanonGrammar -> String prCanon2js :: Options -> CanonGrammar -> String
prCanon2js opts gr = gfcc2js start $ mkCanon2gfcc gr prCanon2js opts gr = gfcc2js start $ mkCanon2gfcc gr
@@ -20,29 +23,37 @@ prCanon2js opts gr = gfcc2js start $ mkCanon2gfcc gr
`mplus` getOptVal grOpts gStartCat) `mplus` getOptVal grOpts gStartCat)
grOpts = errVal noOptions $ lookupOptionsCan gr grOpts = errVal noOptions $ lookupOptionsCan gr
gfcc2js :: String -> C.Grammar -> String gfcc2js :: String -> D.GFCC -> String
gfcc2js start (C.Grm (C.Hdr n _) as cs) = gfcc2js start gfcc =
JS.printTree $ JS.Program $ abstract2js start n as ++ concatMap (concrete2js n) cs JS.printTree $ JS.Program $ abstract2js start n as ++
concatMap (concrete2js n) cs
where
n = D.absname gfcc
as = D.abstract gfcc
cs = Map.assocs (D.concretes gfcc)
abstract2js :: String -> C.CId -> C.Abstract -> [JS.Element] abstract2js :: String -> C.CId -> D.Abstr -> [JS.Element]
abstract2js start (C.CId n) (C.Abs ds) = abstract2js start (C.CId n) ds =
[JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit a (new "Abstract" [JS.EStr start])]] [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit a (new "Abstract" [JS.EStr start])]]
++ concatMap (absdef2js a) ds ++ concatMap (absdef2js a) (Map.assocs (D.funs ds))
where a = JS.Ident n where a = JS.Ident n
absdef2js :: JS.Ident -> C.AbsDef -> [JS.Element] absdef2js :: JS.Ident -> (C.CId,(C.Type,C.Exp)) -> [JS.Element]
absdef2js a (C.Fun (C.CId f) (C.Typ args (C.CId cat)) _) = absdef2js a (C.CId f,(typ,_)) =
let (args,C.CId cat) = M.catSkeleton typ in
[JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar a) (JS.Ident "addType")) [JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar a) (JS.Ident "addType"))
[JS.EStr f, JS.EArray [JS.EStr x | C.CId x <- args], JS.EStr cat]] [JS.EStr f, JS.EArray [JS.EStr x | C.CId x <- args], JS.EStr cat]]
concrete2js :: C.CId -> C.Concrete -> [JS.Element] concrete2js :: C.CId -> (C.CId,D.Concr) -> [JS.Element]
concrete2js (C.CId a) (C.Cnc (C.CId c) ds) = concrete2js (C.CId a) (C.CId c, cnc) =
[JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit l (new "Concrete" [JS.EVar (JS.Ident a)])]] [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit l (new "Concrete" [JS.EVar (JS.Ident a)])]]
++ concatMap (cncdef2js l) ds ++ concatMap (cncdef2js l) ds
where l = JS.Ident c where
l = JS.Ident c
ds = Map.assocs $ D.lins cnc
cncdef2js :: JS.Ident -> C.CncDef -> [JS.Element] cncdef2js :: JS.Ident -> (C.CId,C.Term) -> [JS.Element]
cncdef2js l (C.Lin (C.CId f) t) = cncdef2js l (C.CId f, t) =
[JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "addRule")) [JS.EStr f, JS.EFun [children] [JS.SReturn (term2js l t)]]] [JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "addRule")) [JS.EStr f, JS.EFun [children] [JS.SReturn (term2js l t)]]]
term2js :: JS.Ident -> C.Term -> JS.Expr term2js :: JS.Ident -> C.Term -> JS.Expr

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

@@ -17,8 +17,8 @@ module GF.Compile.ShellState where
import GF.Data.Operations import GF.Data.Operations
import GF.Canon.GFC import GF.Canon.GFC
import GF.Canon.AbsGFC import GF.Canon.AbsGFC
import GF.Canon.GFCC.AbsGFCC(CId(CId)) import GF.GFCC.AbsGFCC(CId(CId))
import GF.Canon.GFCC.DataGFCC(mkGFCC) --import GF.GFCC.DataGFCC(mkGFCC)
import GF.Canon.CanonToGFCC as C2GFCC import GF.Canon.CanonToGFCC as C2GFCC
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.MMacros import GF.Grammar.MMacros
@@ -264,7 +264,7 @@ updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
let fromGFC = snd . snd . Cnv.convertGFC opts let fromGFC = snd . snd . Cnv.convertGFC opts
(mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs
fcfgs0 = [(IC id,g) | (CId id,g) <- fcfgs0 = [(IC id,g) | (CId id,g) <-
FCnv.convertGrammar (mkGFCC (C2GFCC.mkCanon2gfccNoUTF8 cgr))] FCnv.convertGrammar (C2GFCC.mkCanon2gfccNoUTF8 cgr)]
fcfgs = [(c,g) | c <- concrs, Just g <- [lookup c fcfgs0]] fcfgs = [(c,g) | c <- concrs, Just g <- [lookup c fcfgs0]]
pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs

26
src/GF/Conversion/SimpleToFCFG.hs
View File

@@ -21,8 +21,10 @@ import Control.Monad
import GF.Formalism.Utilities import GF.Formalism.Utilities
import GF.Formalism.FCFG import GF.Formalism.FCFG
import GF.Canon.GFCC.AbsGFCC
import GF.Canon.GFCC.DataGFCC import GF.GFCC.Macros hiding (prt)
import GF.GFCC.DataGFCC
import GF.GFCC.AbsGFCC
import GF.Data.BacktrackM import GF.Data.BacktrackM
import GF.Data.SortedList import GF.Data.SortedList
@@ -38,21 +40,24 @@ import Data.Maybe
-- main conversion function -- main conversion function
convertGrammar :: GFCC -> [(CId,FGrammar)] convertGrammar :: GFCC -> [(CId,FGrammar)]
convertGrammar gfcc = [(cncname,convert abs_defs conc) | convertGrammar gfcc = [(cncname,convert abs_defs conc cats) |
cncname <- cncnames gfcc, conc <- Map.lookup cncname (concretes gfcc)] cncname <- cncnames gfcc,
cnc <- Map.lookup cncname (concretes gfcc),
let conc = Map.union (opers cnc) (lins cnc), -- "union big+small most efficient"
let cats = lincats cnc]
where where
abs_defs = Map.assocs (funs (abstract gfcc)) abs_defs = Map.assocs (funs (abstract gfcc))
convert :: [(CId,Type)] -> TermMap -> FGrammar convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar
convert abs_defs cnc_defs = getFRules (loop frulesEnv) convert abs_defs cnc_defs cat_defs = getFRules (loop frulesEnv)
where where
srules = [ srules = [
(XRule id args res (map findLinType args) (findLinType res) term) | (XRule id args res (map findLinType args) (findLinType res) term) |
(id, Typ args res) <- abs_defs, (id, (ty,_)) <- abs_defs, let (args,res) = catSkeleton ty,
term <- Map.lookup id cnc_defs] term <- Map.lookup id cnc_defs]
findLinType (CId id) = fromJust (Map.lookup (CId ("__"++id)) cnc_defs) findLinType id = fromJust (Map.lookup id cat_defs)
(srulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules (srulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules
where where
@@ -128,9 +133,6 @@ convertTerm cnc_defs selector (V nr) ((lbl_path,lin) : lins) = convertArg
convertTerm cnc_defs selector (C nr) ((lbl_path,lin) : lins) = convertCon selector nr lbl_path lin lins convertTerm cnc_defs selector (C nr) ((lbl_path,lin) : lins) = convertCon selector nr lbl_path lin lins
convertTerm cnc_defs selector (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs selector 0 record lbl_path lin lins convertTerm cnc_defs selector (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs selector 0 record lbl_path lin lins
----convertTerm cnc_defs selector (P term (R ts)) lins =
---- convertTerm cnc_defs selector (foldl P term ts) lins ---- ?? AR 2/10/2007
convertTerm cnc_defs selector (P term sel) lins = do nr <- evalTerm cnc_defs [] sel convertTerm cnc_defs selector (P term sel) lins = do nr <- evalTerm cnc_defs [] sel
convertTerm cnc_defs (TuplePrj nr selector) term lins convertTerm cnc_defs (TuplePrj nr selector) term lins
convertTerm cnc_defs selector (FV vars) lins = do term <- member vars convertTerm cnc_defs selector (FV vars) lins = do term <- member vars
@@ -169,7 +171,7 @@ convertArg (ConSel indices) nr path lbl_path lin lins = do
convertArg StrSel nr path lbl_path lin lins = do convertArg StrSel nr path lbl_path lin lins = do
projectHead lbl_path projectHead lbl_path
xnr <- projectArg nr path xnr <- projectArg nr path
return ((lbl_path, Cat (path, nr, xnr) : lin) : lins) return ((lbl_path, GF.Formalism.Utilities.Cat (path, nr, xnr) : lin) : lins)
convertCon (ConSel indices) index lbl_path lin lins = do convertCon (ConSel indices) index lbl_path lin lins = do
guard (index `elem` indices) guard (index `elem` indices)

2
src/GF/Devel/GFC.hs
View File

@@ -2,7 +2,7 @@ module Main where
import GF.Devel.Compile import GF.Devel.Compile
import GF.Devel.GrammarToGFCC import GF.Devel.GrammarToGFCC
import GF.Devel.OptimizeGFCC import GF.GFCC.OptimizeGFCC
import GF.GFCC.CheckGFCC import GF.GFCC.CheckGFCC
import GF.GFCC.DataGFCC import GF.GFCC.DataGFCC
import GF.Devel.UseIO import GF.Devel.UseIO

2
src/GF/Formalism/FCFG.hs
View File

@@ -39,7 +39,7 @@ import Data.List (groupBy)
import Data.Array import Data.Array
import GF.Formalism.Utilities import GF.Formalism.Utilities
import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC import qualified GF.GFCC.AbsGFCC as AbsGFCC
import GF.Infra.PrintClass import GF.Infra.PrintClass

2
src/GF/Devel/OptimizeGFCC.hs → src/GF/GFCC/OptimizeGFCC.hs
View File

@@ -1,4 +1,4 @@
module GF.Devel.OptimizeGFCC where module GF.GFCC.OptimizeGFCC where
import GF.GFCC.AbsGFCC import GF.GFCC.AbsGFCC
import GF.GFCC.DataGFCC import GF.GFCC.DataGFCC

15
src/GF/Parsing/FCFG.hs
View File

@@ -21,8 +21,9 @@ import GF.Formalism.Utilities
import qualified GF.Parsing.FCFG.Active as Active import qualified GF.Parsing.FCFG.Active as Active
import GF.Parsing.FCFG.PInfo import GF.Parsing.FCFG.PInfo
import GF.Canon.GFCC.AbsGFCC import GF.GFCC.AbsGFCC
import GF.Canon.GFCC.ErrM import GF.GFCC.Macros
import GF.GFCC.ErrM
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -74,12 +75,12 @@ cnv_forests2 (FFloat x) = FFloat x
-- parse trees to GFCC terms -- parse trees to GFCC terms
tree2term :: SyntaxTree CId -> Exp tree2term :: SyntaxTree CId -> Exp
tree2term (TNode f ts) = Tr (AC f) (map tree2term ts) tree2term (TNode f ts) = tree (AC f) (map tree2term ts)
tree2term (TString s) = Tr (AS s) [] tree2term (TString s) = tree (AS s) []
tree2term (TInt n) = Tr (AI n) [] tree2term (TInt n) = tree (AI n) []
tree2term (TFloat f) = Tr (AF f) [] tree2term (TFloat f) = tree (AF f) []
tree2term (TMeta) = Tr AM [] tree2term (TMeta) = exp0
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- conversion and unification of forests -- conversion and unification of forests

9
src/GF/Parsing/GFC.hs
View File

@@ -24,8 +24,8 @@ import GF.Data.Operations (Err(..))
import qualified GF.Grammar.Grammar as Grammar import qualified GF.Grammar.Grammar as Grammar
import qualified GF.Grammar.Macros as Macros import qualified GF.Grammar.Macros as Macros
import qualified GF.Canon.AbsGFC as AbsGFC import qualified GF.Canon.AbsGFC as AbsGFC
import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC import qualified GF.GFCC.AbsGFCC as AbsGFCC
import qualified GF.Canon.GFCC.ErrM as ErrM import qualified GF.GFCC.ErrM as ErrM
import qualified GF.Infra.Ident as Ident import qualified GF.Infra.Ident as Ident
import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok, prCFTok) import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok, prCFTok)
@@ -169,14 +169,15 @@ tree2term abs (TFloat f) = Macros.float2term f
tree2term abs (TMeta) = Macros.mkMeta 0 tree2term abs (TMeta) = Macros.mkMeta 0
exp2term :: Ident.Ident -> AbsGFCC.Exp -> Grammar.Term exp2term :: Ident.Ident -> AbsGFCC.Exp -> Grammar.Term
exp2term abs (AbsGFCC.Tr a es) = Macros.mkApp (atom2term abs a) (map (exp2term abs) es) exp2term abs (AbsGFCC.DTr _ a es) = ---- TODO: bindings
Macros.mkApp (atom2term abs a) (map (exp2term abs) es)
atom2term :: Ident.Ident -> AbsGFCC.Atom -> Grammar.Term atom2term :: Ident.Ident -> AbsGFCC.Atom -> Grammar.Term
atom2term abs (AbsGFCC.AC (AbsGFCC.CId f)) = Macros.qq (abs,Ident.IC f) atom2term abs (AbsGFCC.AC (AbsGFCC.CId f)) = Macros.qq (abs,Ident.IC f)
atom2term abs (AbsGFCC.AS s) = Macros.string2term s atom2term abs (AbsGFCC.AS s) = Macros.string2term s
atom2term abs (AbsGFCC.AI n) = Macros.int2term n atom2term abs (AbsGFCC.AI n) = Macros.int2term n
atom2term abs (AbsGFCC.AF f) = Macros.float2term f atom2term abs (AbsGFCC.AF f) = Macros.float2term f
atom2term abs AbsGFCC.AM = Macros.mkMeta 0 atom2term abs (AbsGFCC.AM i) = Macros.mkMeta (fromInteger i)
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- conversion and unification of forests -- conversion and unification of forests

12
src/GF/Speech/GrammarToVoiceXML.hs
View File

@@ -11,9 +11,9 @@
module GF.Speech.GrammarToVoiceXML (grammar2vxml) where module GF.Speech.GrammarToVoiceXML (grammar2vxml) where
import GF.Canon.CanonToGFCC (mkCanon2gfcc) import GF.Canon.CanonToGFCC (mkCanon2gfcc)
import qualified GF.Canon.GFCC.AbsGFCC as C import qualified GF.GFCC.AbsGFCC as C
import GF.Canon.GFCC.DataGFCC (GFCC(..), Abstr(..), mkGFCC, lookMap) import GF.GFCC.DataGFCC (GFCC(..), Abstr(..), mkGFCC)
import GF.GFCC.Macros
import qualified GF.Canon.GFC as GFC import qualified GF.Canon.GFC as GFC
import GF.Canon.AbsGFC (Term) import GF.Canon.AbsGFC (Term)
import GF.Canon.PrintGFC (printTree) import GF.Canon.PrintGFC (printTree)
@@ -65,14 +65,14 @@ prid :: VIdent -> String
prid (C.CId x) = x prid (C.CId x) = x
vSkeleton :: GFC.CanonGrammar -> (VIdent,VSkeleton) vSkeleton :: GFC.CanonGrammar -> (VIdent,VSkeleton)
vSkeleton = gfccSkeleton . mkGFCC . mkCanon2gfcc vSkeleton = gfccSkeleton . mkCanon2gfcc
gfccSkeleton :: GFCC -> (VIdent,VSkeleton) gfccSkeleton :: GFCC -> (VIdent,VSkeleton)
gfccSkeleton gfcc = (absname gfcc, ts) gfccSkeleton gfcc = (absname gfcc, ts)
where a = abstract gfcc where a = abstract gfcc
ts = [(c,[(f,ft f) | f <- fs]) | (c,fs) <- Map.toList (cats a)] ts = [(c,[(f,ft f) | f <- fs]) | (c,fs) <- Map.toList (catfuns a)]
ft f = case lookMap (error $ prid f) f (funs a) of ft f = case lookMap (error $ prid f) f (funs a) of
C.Typ args _ -> args (ty,_) -> fst $ GF.GFCC.Macros.catSkeleton ty
-- --
-- * Questions to ask -- * Questions to ask

9
src/GF/Speech/TransformCFG.hs
View File

@@ -17,8 +17,9 @@
module GF.Speech.TransformCFG where module GF.Speech.TransformCFG where
import GF.Canon.CanonToGFCC (mkCanon2gfcc) import GF.Canon.CanonToGFCC (mkCanon2gfcc)
import qualified GF.Canon.GFCC.AbsGFCC as C import qualified GF.GFCC.AbsGFCC as C
import GF.Canon.GFCC.DataGFCC (GFCC, mkGFCC, lookType) import GF.GFCC.Macros (lookType,catSkeleton)
import GF.GFCC.DataGFCC (GFCC)
import GF.Conversion.Types import GF.Conversion.Types
import GF.CF.PPrCF (prCFCat) import GF.CF.PPrCF (prCFCat)
import GF.Data.Utilities import GF.Data.Utilities
@@ -70,7 +71,7 @@ cfgToCFRules s =
nameToTerm (Name IW [Unify [n]]) = CFRes n nameToTerm (Name IW [Unify [n]]) = CFRes n
nameToTerm (Name f@(IC c) prs) = nameToTerm (Name f@(IC c) prs) =
CFObj f (zipWith profileToTerm args prs) CFObj f (zipWith profileToTerm args prs)
where C.Typ args _ = lookType gfcc (C.CId c) where (args,_) = catSkeleton $ lookType gfcc (C.CId c)
nameToTerm n = error $ "cfgToCFRules.nameToTerm" ++ show n nameToTerm n = error $ "cfgToCFRules.nameToTerm" ++ show n
profileToTerm (C.CId t) (Unify []) = CFMeta t profileToTerm (C.CId t) (Unify []) = CFMeta t
profileToTerm _ (Unify xs) = CFRes (last xs) -- FIXME: unify profileToTerm _ (Unify xs) = CFRes (last xs) -- FIXME: unify
@@ -84,7 +85,7 @@ getStartCatCF :: Options -> StateGrammar -> String
getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s" getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s"
stateGFCC :: StateGrammar -> GFCC stateGFCC :: StateGrammar -> GFCC
stateGFCC = mkGFCC . mkCanon2gfcc . stateGrammarST stateGFCC = mkCanon2gfcc . stateGrammarST
-- * Grammar filtering -- * Grammar filtering

6
src/GF/UseGrammar/Custom.hs
View File

@@ -35,8 +35,8 @@ import qualified GF.Grammar.Grammar as G
import qualified GF.Canon.AbsGFC as A import qualified GF.Canon.AbsGFC as A
import qualified GF.Canon.GFC as C import qualified GF.Canon.GFC as C
import qualified GF.Canon.CanonToGFCC as GFCC import qualified GF.Canon.CanonToGFCC as GFCC
import qualified GF.Canon.GFCC.GFCCToHaskell as CCH import qualified GF.Devel.GFCCtoHaskell as CCH
import qualified GF.Canon.GFCC.DataGFCC as DataGFCC import qualified GF.GFCC.DataGFCC as DataGFCC
import qualified GF.Canon.CanonToJS as JS (prCanon2js) import qualified GF.Canon.CanonToJS as JS (prCanon2js)
import qualified GF.Source.AbsGF as GF import qualified GF.Source.AbsGF as GF
import qualified GF.Grammar.MMacros as MM import qualified GF.Grammar.MMacros as MM
@@ -274,7 +274,7 @@ customGrammarPrinter =
,(strCI "bnf", \_ -> prBNF False) ,(strCI "bnf", \_ -> prBNF False)
,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST) ,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST)
,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST) ,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST)
,(strCI "gfcc_haskell", \_ -> CCH.grammar2haskell . DataGFCC.mkGFCC . ,(strCI "gfcc_haskell", \_ -> CCH.grammar2haskell .
GFCC.mkCanon2gfcc . stateGrammarST) GFCC.mkCanon2gfcc . stateGrammarST)
,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST) ,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST)
,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST) ,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST)