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

GFCC to FCFG conversion

Browse Source
This commit is contained in:
kr_angelov
2006-12-28 16:45:57 +00:00
parent 094cab7057
commit 82ca4a89df
11 changed files with 276 additions and 286 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -17,6 +17,7 @@ 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.CanonToGFCC as C2GFCC
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.MMacros import GF.Grammar.MMacros
@@ -43,6 +44,7 @@ import qualified Transfer.InterpreterAPI as T
import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE
import qualified GF.Conversion.GFC as Cnv import qualified GF.Conversion.GFC as Cnv
import qualified GF.Conversion.SimpleToFCFG as FCnv
import qualified GF.Parsing.GFC as Prs import qualified GF.Parsing.GFC as Prs
import Control.Monad (mplus) import Control.Monad (mplus)
@@ -229,8 +231,11 @@ updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $ let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $
maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh
let cgr = cgr0 ---- filterAbstracts (map fst abstrs) cgr0 let needed = nub $ concatMap (requiredCanModules (length abstrs == 1) cgr0) (maybe [] singleton abstr0 ++ concrs0)
purge = nubBy (\x y -> fst x == fst y) . filter (\(m,mo) -> elem m needed && not (isIncompleteCanon (m,mo)))
let cgr = M.MGrammar $ purge $ M.modules cgr0
let oldConcrs = map (snd . fst) (concretes sh) let oldConcrs = map (snd . fst) (concretes sh)
newConcrs = maybe [] (M.allConcretes gr) abstr0 newConcrs = maybe [] (M.allConcretes gr) abstr0
@@ -238,7 +243,8 @@ updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
let complete m = case M.lookupModule gr m of let complete m = case M.lookupModule gr m of
Ok mo -> not $ isIncompleteCanon (m,mo) Ok mo -> not $ isIncompleteCanon (m,mo)
_ -> False _ -> False
let concrs = filter complete $ nub $ newConcrs ++ oldConcrs
let concrs = filter (\i -> complete i && elem i needed) $ nub $ newConcrs ++ oldConcrs
concr0 = ifNull Nothing (return . head) concrs concr0 = ifNull Nothing (return . head) concrs
notInrts f = notElem f $ map fst rts notInrts f = notElem f $ map fst rts
subcgr = unSubelimCanon cgr subcgr = unSubelimCanon cgr
@@ -252,9 +258,12 @@ updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
let probss = [] ----- let probss = [] -----
let fromGFC = snd . snd . Cnv.convertGFC opts let fromGFC = snd . snd . Cnv.convertGFC opts
(mcfgs, fcfgs, cfgs) = unzip3 $ map (curry fromGFC cgr) concrs (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs
pInfos = zipWith3 Prs.buildPInfo mcfgs fcfgs cfgs fcfgs = FCnv.convertGrammar (C2GFCC.mkCanon2gfcc cgr)
pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs
let funs = funRulesOf cgr let funs = funRulesOf cgr
let cats = allCatsOf cgr let cats = allCatsOf cgr
@@ -273,9 +282,9 @@ updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
canModules = cgr, canModules = cgr,
srcModules = src, srcModules = src,
cfs = cf's, cfs = cf's,
abstracts = abstrs, abstracts = maybe [] (\a -> [(a,concrs)]) abstr0,
mcfgs = zip concrs mcfgs, mcfgs = zip concrs mcfgs,
fcfgs = zip concrs fcfgs, fcfgs = fcfgs,
cfgs = zip concrs cfgs, cfgs = zip concrs cfgs,
pInfos = zip concrs pInfos, pInfos = zip concrs pInfos,
morphos = morphs, morphos = morphs,

24
src/GF/Conversion/GFC.hs
View File

@@ -18,6 +18,7 @@ module GF.Conversion.GFC
import GF.Infra.Option import GF.Infra.Option
import GF.Canon.GFC (CanonGrammar) import GF.Canon.GFC (CanonGrammar)
import GF.Infra.Ident (Ident, identC) import GF.Infra.Ident (Ident, identC)
import qualified GF.Infra.Modules as M
import GF.Formalism.GCFG (Rule(..), Abstract(..)) import GF.Formalism.GCFG (Rule(..), Abstract(..))
import GF.Formalism.SimpleGFC (decl2cat) import GF.Formalism.SimpleGFC (decl2cat)
@@ -31,23 +32,22 @@ import qualified GF.Conversion.RemoveSingletons as RemSing
import qualified GF.Conversion.RemoveErasing as RemEra import qualified GF.Conversion.RemoveErasing as RemEra
import qualified GF.Conversion.RemoveEpsilon as RemEps import qualified GF.Conversion.RemoveEpsilon as RemEps
import qualified GF.Conversion.SimpleToMCFG as S2M import qualified GF.Conversion.SimpleToMCFG as S2M
import qualified GF.Conversion.SimpleToFCFG as S2FM
--import qualified GF.Conversion.MCFGtoFCFG as M2FM
import qualified GF.Conversion.MCFGtoCFG as M2C import qualified GF.Conversion.MCFGtoCFG as M2C
import GF.Infra.Print import GF.Infra.Print
import GF.System.Tracing import GF.System.Tracing
import qualified Debug.Trace as D
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- * GFC -> MCFG & CFG, using options to decide which conversion is used -- * GFC -> MCFG & CFG, using options to decide which conversion is used
convertGFC :: Options -> (CanonGrammar, Ident) convertGFC :: Options -> (CanonGrammar, Ident)
-> (SGrammar, (EGrammar, (MGrammar, FGrammar, CGrammar))) -> (SGrammar, (EGrammar, (MGrammar, CGrammar)))
convertGFC opts = \g -> let s = g2s g convertGFC opts = \g -> let s = g2s g
e = s2e s e = s2e s
m = e2m e m = e2m e
in trace2 "Options" (show opts) (s, (e, (m, s2fm s, e2c e))) in D.trace (show ((M.greatestAbstract (fst g),snd g))) $ trace2 "Options" (show opts) (s, (e, (m, e2c e)))
where e2c = M2C.convertGrammar where e2c = M2C.convertGrammar
e2m = case getOptVal opts firstCat of e2m = case getOptVal opts firstCat of
Just cat -> flip erasing [identC cat] Just cat -> flip erasing [identC cat]
@@ -57,8 +57,6 @@ convertGFC opts = \g -> let s = g2s g
Just "finite-strict" -> strict Just "finite-strict" -> strict
Just "epsilon" -> epsilon . nondet Just "epsilon" -> epsilon . nondet
_ -> nondet _ -> nondet
s2fm= S2FM.convertGrammar
m2fm= undefined --M2FM.convertGrammar
g2s = case getOptVal opts gfcConversion of g2s = case getOptVal opts gfcConversion of
Just "finite" -> finite . simple Just "finite" -> finite . simple
Just "finite2" -> finite . finite . simple Just "finite2" -> finite . finite . simple
@@ -82,20 +80,12 @@ gfc2simple opts = fst . convertGFC opts
gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar
gfc2mcfg opts g = mcfg gfc2mcfg opts g = mcfg
where where
(mcfg, _, _) = snd (snd (convertGFC opts g)) (mcfg, _) = snd (snd (convertGFC opts g))
gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar
gfc2cfg opts g = cfg gfc2cfg opts g = cfg
where where
(_, _, cfg) = snd (snd (convertGFC opts g)) (_, cfg) = snd (snd (convertGFC opts g))
gfc2fcfg :: Options -> (CanonGrammar, Ident) -> FGrammar
gfc2fcfg opts g = fcfg
where
(_, fcfg, _) = snd (snd (convertGFC opts g))
mcfg2fcfg :: MGrammar -> FGrammar
mcfg2fcfg = undefined --M2FM.convertGrammar
---------------------------------------------------------------------- ----------------------------------------------------------------------

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

@@ -22,11 +22,10 @@ import GF.Infra.Ident
import Control.Monad import Control.Monad
import GF.Formalism.Utilities import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.FCFG import GF.Formalism.FCFG
import GF.Formalism.SimpleGFC
import GF.Conversion.Types import GF.Conversion.Types
import GF.Canon.AbsGFC(CIdent(..)) import GF.Canon.GFCC.AbsGFCC
import GF.Canon.GFCC.DataGFCC
import GF.Data.BacktrackM import GF.Data.BacktrackM
import GF.Data.SortedList import GF.Data.SortedList
@@ -36,40 +35,47 @@ import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.List as List import qualified Data.List as List
import Data.Array import Data.Array
import Data.Maybe
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- main conversion function -- main conversion function
convertGrammar :: SGrammar -> FGrammar convertGrammar :: Grammar -> [(Ident,FGrammar)]
convertGrammar srules = getFRules (loop frulesEnv) convertGrammar g@(Grm hdr (Abs abs_defs) cncs) = [(i2i cncname,convert abs_defs conc) | cncname <- cncnames gfcc, conc <- Map.lookup cncname (concretes gfcc)]
where where
(srulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules gfcc = mkGFCC g
i2i (CId i) = IC i
convert :: [AbsDef] -> TermMap -> FGrammar
convert abs_defs cnc_defs = getFRules (loop frulesEnv)
where where
helper (srulesMap,frulesEnv) rule@(Rule (Abs decl _ _) (Cnc ctype _ _)) = srules = [(XRule id args res (map findLinType args) (findLinType res) term) | Fun id (Typ args res) exp <- abs_defs, term <- Map.lookup id cnc_defs]
let srulesMap' = Map.insertWith (++) (decl2cat decl) [rule] srulesMap
frulesEnv' = List.foldl' (\env selector -> convertRule selector rule env) findLinType (CId id) = fromJust (Map.lookup (CId ("__"++id)) cnc_defs)
frulesEnv
(mkSingletonSelectors ctype)
in srulesMap' `seq` frulesEnv' `seq` (srulesMap',frulesEnv')
loop frulesEnv = (srulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules
let (todo, frulesEnv') = takeToDoRules srulesMap frulesEnv where
in case todo of helper (srulesMap,frulesEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) =
[] -> frulesEnv' let srulesMap' = Map.insertWith (++) abs_res [rule] srulesMap
_ -> loop $! List.foldl' (\env (srules,selector) -> frulesEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env)
List.foldl' (\env srule -> convertRule selector srule env) env srules) frulesEnv' todo frulesEnv
(mkSingletonSelectors cnc_res)
in srulesMap' `seq` frulesEnv' `seq` (srulesMap',frulesEnv')
loop frulesEnv =
let (todo, frulesEnv') = takeToDoRules srulesMap frulesEnv
in case todo of
[] -> frulesEnv'
_ -> loop $! List.foldl' (\env (srules,selector) ->
List.foldl' (\env srule -> convertRule cnc_defs selector srule env) env srules) frulesEnv' todo
---------------------------------------------------------------------- convertRule :: TermMap -> TermSelector -> XRule -> FRulesEnv -> FRulesEnv
-- rule conversion convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) frulesEnv =
convertRule :: STermSelector -> SRule -> FRulesEnv -> FRulesEnv
convertRule selector (Rule (Abs decl decls (Name fun profile)) (Cnc ctype ctypes (Just term))) frulesEnv =
foldBM addRule foldBM addRule
frulesEnv frulesEnv
(convertTerm selector term [Lin emptyPath []]) (convertTerm cnc_defs selector term [([],[])])
(let cat : args = map decl2cat (decl : decls) (initialFCat cat, map (\scat -> (initialFCat scat,[])) args, ctype, ctypes)
in (initialFCat cat, map (\scat -> (initialFCat scat,[])) args, ctype, ctypes))
where where
addRule linRec (newCat', newArgs', _, _) env0 = addRule linRec (newCat', newArgs', _, _) env0 =
let (env1, newCat) = genFCatHead env0 newCat' let (env1, newCat) = genFCatHead env0 newCat'
@@ -79,7 +85,7 @@ convertRule selector (Rule (Abs decl decls (Name fun profile)) (Cnc ctype ctypes
in case fcat of in case fcat of
FCat _ _ [] _ -> (env , args, all_args) FCat _ _ [] _ -> (env , args, all_args)
_ -> (env1,xargs1++args,(idx,xargs1):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..]) _ -> (env1,xargs1++args,(idx,xargs1):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..])
newLinRec = listArray (0,length linRec-1) [translateLin idxArgs path linRec | path <- case newCat of {FCat _ _ rcs _ -> rcs}] newLinRec = listArray (0,length linRec-1) [translateLin idxArgs path linRec | path <- case newCat of {FCat _ _ rcs _ -> rcs}]
(_,newProfile) = List.mapAccumL accumProf 0 newArgs' (_,newProfile) = List.mapAccumL accumProf 0 newArgs'
@@ -88,16 +94,15 @@ convertRule selector (Rule (Abs decl decls (Name fun profile)) (Cnc ctype ctypes
accumProf nr (_ ,xpaths) = (nr+cnt+1, Unify [nr..nr+cnt]) accumProf nr (_ ,xpaths) = (nr+cnt+1, Unify [nr..nr+cnt])
where cnt = length xpaths where cnt = length xpaths
rule = FRule (Abs newCat newArgs (Name fun newProfile)) newLinRec rule = FRule (Name fun newProfile) newArgs newCat newLinRec
in addFCatRule env2 rule in addFCatRule env2 rule
convertRule selector _ frulesEnv = frulesEnv
translateLin idxArgs lbl' [] = array (0,-1) [] translateLin idxArgs lbl' [] = array (0,-1) []
translateLin idxArgs lbl' (Lin lbl syms : lins) translateLin idxArgs lbl' ((lbl,syms) : lins)
| lbl' == lbl = listArray (0,length syms-1) (map instSym syms) | lbl' == lbl = listArray (0,length syms-1) (map instSym syms)
| otherwise = translateLin idxArgs lbl' lins | otherwise = translateLin idxArgs lbl' lins
where where
instSym = symbol (\(_, lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) FSymTok instSym = symbol (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) FSymTok
instCat lbl nr xnr nr' ((idx,xargs):idxArgs) instCat lbl nr xnr nr' ((idx,xargs):idxArgs)
| nr == idx = let arg@(FCat _ _ rcs _) = xargs !! xnr | nr == idx = let arg@(FCat _ _ rcs _) = xargs !! xnr
in FSymCat arg (index lbl rcs 0) (nr'+xnr) in FSymCat arg (index lbl rcs 0) (nr'+xnr)
@@ -107,139 +112,115 @@ translateLin idxArgs lbl' (Lin lbl syms : lins)
| lbl' == lbl = idx | lbl' == lbl = idx
| otherwise = index lbl' lbls $! (idx+1) | otherwise = index lbl' lbls $! (idx+1)
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- term conversion -- term conversion
type CnvMonad a = BacktrackM Env a type CnvMonad a = BacktrackM Env a
type Env = (FCat, [(FCat,[SPath])], SLinType, [SLinType]) type Env = (FCat, [(FCat,[FPath])], Term, [Term])
type LinRec = [Lin SCat SPath Token] type LinRec = [(FPath, [Symbol (FPath, FIndex, Int) Token])]
data Lin cat lbl tok = Lin lbl [Symbol (cat, lbl, Int, Int) tok] type TermMap = Map.Map CId Term
convertTerm :: TermMap -> TermSelector -> Term -> LinRec -> CnvMonad LinRec
convertTerm cnc_defs selector (V nr) ((lbl_path,lin) : lins) = convertArg 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 (P term sel) lins = do nr <- evalTerm cnc_defs [] sel
convertTerm cnc_defs (TuplePrj nr selector) term lins
convertTerm cnc_defs selector (FV vars) lins = do term <- member vars
convertTerm cnc_defs selector term lins
convertTerm cnc_defs selector (S ts) ((lbl_path,lin) : lins) = do projectHead lbl_path
foldM (\lins t -> convertTerm cnc_defs selector t lins) ((lbl_path,lin) : lins) (reverse ts)
convertTerm cnc_defs selector (KS str) ((lbl_path,lin) : lins) = do projectHead lbl_path
return ((lbl_path,Tok str : lin) : lins)
convertTerm cnc_defs selector (KP (str:_)_)((lbl_path,lin) : lins) = do projectHead lbl_path
return ((lbl_path,Tok str : lin) : lins)
convertTerm cnc_defs selector (RP alias _) lins = convertTerm cnc_defs selector alias lins
convertTerm cnc_defs selector (F id) lins = do term <- Map.lookup id cnc_defs
convertTerm cnc_defs selector term lins
convertTerm cnc_defs selector (W s ss) ((lbl_path,lin) : lins) = convertRec cnc_defs selector 0 [KS (s ++ s1) | s1 <- ss] lbl_path lin lins
convertTerm cnc_defs selector x lins = error ("convertTerm ("++show x++")")
convertTerm :: STermSelector -> STerm -> LinRec -> CnvMonad LinRec convertArg (TupleSel record) nr path lbl_path lin lins =
convertTerm selector (Arg nr cat path) (Lin lbl_path lin : lins) = convertArg selector nr cat path lbl_path lin lins foldM (\lins (lbl, selector) -> convertArg selector nr (lbl:path) (lbl:lbl_path) lin lins) lins record
convertTerm selector (con :^ args) (Lin lbl_path lin : lins) = convertCon selector con args lbl_path lin lins convertArg (TuplePrj lbl selector) nr path lbl_path lin lins =
convertTerm selector (Rec record) (Lin lbl_path lin : lins) = convertRec selector record lbl_path lin lins convertArg selector nr (lbl:path) lbl_path lin lins
convertTerm selector (term :. lbl) lins = convertTerm (RecPrj lbl selector) term lins convertArg (ConSel indices) nr path lbl_path lin lins = do
convertTerm selector (Tbl table) (Lin lbl_path lin : lins) = convertTbl selector table lbl_path lin lins index <- member indices
convertTerm selector (term :! sel) lins = do sel <- evalTerm sel restrictHead lbl_path index
convertTerm (TblPrj sel selector) term lins restrictArg nr path index
convertTerm selector (Variants vars) lins = do term <- member vars
convertTerm selector term lins
convertTerm selector (t1 :++ t2) lins = do lins <- convertTerm selector t2 lins
lins <- convertTerm selector t1 lins
return lins
convertTerm selector (Token str) (Lin lbl_path lin : lins) = do projectHead lbl_path
return (Lin lbl_path (Tok str : lin) : lins)
convertTerm selector (Empty ) (Lin lbl_path lin : lins) = do projectHead lbl_path
return (Lin lbl_path lin : lins)
convertArg (RecSel record) nr cat path lbl_path lin lins =
foldM (\lins (lbl, selector) -> convertArg selector nr cat (path ++. lbl) (lbl_path ++. lbl) lin lins) lins record
convertArg (TblSel cases) nr cat path lbl_path lin lins =
foldM (\lins (term, selector) -> convertArg selector nr cat (path ++! term) (lbl_path ++! term) lin lins) lins cases
convertArg (RecPrj lbl selector) nr cat path lbl_path lin lins =
convertArg selector nr cat (path ++. lbl ) lbl_path lin lins
convertArg (TblPrj term selector) nr cat path lbl_path lin lins =
convertArg selector nr cat (path ++! term) lbl_path lin lins
convertArg (ConSel terms) nr cat path lbl_path lin lins = do
sel <- member terms
restrictHead lbl_path sel
restrictArg nr path sel
return lins return lins
convertArg StrSel nr cat 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 (Lin lbl_path (Cat (cat, path, nr, xnr) : lin) : lins) return ((lbl_path, Cat (path, nr, xnr) : lin) : lins)
convertCon (ConSel terms) con args lbl_path lin lins = do convertCon (ConSel indices) index lbl_path lin lins = do
args <- mapM evalTerm args guard (index `elem` indices)
let term = con :^ args restrictHead lbl_path index
guard (term `elem` terms)
restrictHead lbl_path term
return lins return lins
convertRec selector [] lbl_path lin lins = return lins convertRec cnc_defs selector index [] lbl_path lin lins = return lins
convertRec selector@(RecSel fields) ((label, val):record) lbl_path lin lins = select fields convertRec cnc_defs selector@(TupleSel fields) index (val:record) lbl_path lin lins = select fields
where where
select [] = convertRec selector record lbl_path lin lins select [] = convertRec cnc_defs selector (index+1) record lbl_path lin lins
select ((label',sub_sel) : fields) select ((index',sub_sel) : fields)
| label == label' = do lins <- convertTerm sub_sel val (Lin (lbl_path ++. label) lin : lins) | index == index' = do lins <- convertTerm cnc_defs sub_sel val ((index:lbl_path,lin) : lins)
convertRec selector record lbl_path lin lins convertRec cnc_defs selector (index+1) record lbl_path lin lins
| otherwise = select fields | otherwise = select fields
convertRec (RecPrj label sub_sel) record lbl_path lin lins = do convertRec cnc_defs (TuplePrj index' sub_sel) index record lbl_path lin lins = do
(label',val) <- member record convertTerm cnc_defs sub_sel (record !! (fromIntegral (index'-index))) ((lbl_path,lin) : lins)
guard (label==label')
convertTerm sub_sel val (Lin lbl_path lin : lins)
convertTbl selector [] lbl_path lin lins = return lins
convertTbl selector@(TblSel cases) ((term, val):table) lbl_path lin lins = case selector of { TblSel cases -> select cases }
where
select [] = convertTbl selector table lbl_path lin lins
select ((term',sub_sel) : cases)
| term == term' = do lins <- convertTerm sub_sel val (Lin (lbl_path ++! term) lin : lins)
convertTbl selector table lbl_path lin lins
| otherwise = select cases
convertTbl (TblPrj term sub_sel) table lbl_path lin lins = do
(term',val) <- member table
guard (term==term')
convertTerm sub_sel val (Lin lbl_path lin : lins)
------------------------------------------------------------ ------------------------------------------------------------
-- eval a term to ground terms -- eval a term to ground terms
evalTerm :: STerm -> CnvMonad STerm evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex
evalTerm arg@(Arg nr _ path) = do ctype <- readArgCType nr evalTerm cnc_defs path (V nr) = do term <- readArgCType nr
unifyPType arg $ lintypeFollowPath path ctype unifyPType nr (reverse path) (selectTerm path term)
evalTerm (con :^ terms) = do terms <- mapM evalTerm terms evalTerm cnc_defs path (C nr) = return nr
return (con :^ terms) evalTerm cnc_defs path (R record) = case path of
evalTerm (Rec record) = do record <- mapM evalAssign record (index:path) -> evalTerm cnc_defs path (record !! (fromIntegral index))
return (Rec record) evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel
evalTerm (term :. lbl) = do term <- evalTerm term evalTerm cnc_defs (index:path) term
evalTerm (term +. lbl) evalTerm cnc_defs path (FV terms) = member terms >>= evalTerm cnc_defs path
evalTerm (Tbl table) = do table <- mapM evalCase table evalTerm cnc_defs path (RP alias _) = evalTerm cnc_defs path alias
return (Tbl table) evalTerm cnc_defs path (F id) = do term <- Map.lookup id cnc_defs
evalTerm (term :! sel) = do sel <- evalTerm sel evalTerm cnc_defs path term
evalTerm (term +! sel) evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
evalTerm (Variants terms) = member terms >>= evalTerm
evalTerm (t1 :++ t2) = do t1 <- evalTerm t1
t2 <- evalTerm t2
return (t1 :++ t2)
evalTerm (Token str) = do return (Token str)
evalTerm Empty = do return Empty
evalAssign :: (Label, STerm) -> CnvMonad (Label, STerm) unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex
evalAssign (lbl, term) = liftM ((,) lbl) $ evalTerm term unifyPType nr path (C max_index) =
evalCase :: (STerm, STerm) -> CnvMonad (STerm, STerm)
evalCase (pat, term) = liftM2 (,) (evalTerm pat) (evalTerm term)
unifyPType :: STerm -> SLinType -> CnvMonad STerm
unifyPType arg (RecT prec) =
liftM Rec $
sequence [ liftM ((,) lbl) $
unifyPType (arg +. lbl) ptype |
(lbl, ptype) <- prec ]
unifyPType (Arg nr _ path) (ConT terms) =
do (_, args, _, _) <- readState do (_, args, _, _) <- readState
let (FCat _ _ _ tcs,_) = args !! nr let (FCat _ _ _ tcs,_) = args !! (fromIntegral nr)
case lookup path tcs of case lookup path tcs of
Just term -> return term Just index -> return index
Nothing -> do term <- member terms Nothing -> do index <- member [0..max_index-1]
restrictArg nr path term restrictArg nr path index
return term return index
unifyPType nr path (RP alias _) = unifyPType nr path alias
selectTerm :: FPath -> Term -> Term
selectTerm [] term = term
selectTerm (index:path) (R record) = selectTerm path (record !! fromIntegral index)
selectTerm path (RP _ term) = selectTerm path term
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- FRulesEnv -- FRulesEnv
data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule] data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule]
type SRulesMap = Map.Map SCat [SRule] type XRulesMap = Map.Map CId [XRule]
type FCatSet = Map.Map SCat (Map.Map [SPath] (Map.Map [(SPath,STerm)] (Either FCat FCat))) data XRule = XRule CId {- function -}
[CId] {- argument types -}
CId {- result type -}
[Term] {- argument lin-types representation -}
Term {- result lin-type representation -}
Term {- body -}
type FCatSet = Map.Map CId (Map.Map [FPath] (Map.Map [(FPath,FIndex)] (Either FCat FCat)))
emptyFRulesEnv = FRulesEnv 0 (ins fcatString (ins fcatInt (ins fcatFloat Map.empty))) [] emptyFRulesEnv = FRulesEnv 0 (ins fcatString (ins fcatInt (ins fcatFloat Map.empty))) []
@@ -266,7 +247,7 @@ genFCatHead env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =
tmap_s = Map.singleton tcs x_fcat tmap_s = Map.singleton tcs x_fcat
rmap_s = Map.singleton rcs tmap_s rmap_s = Map.singleton rcs tmap_s
genFCatArg :: SLinType -> FRulesEnv -> FCat -> (FRulesEnv, FCat) genFCatArg :: Term -> FRulesEnv -> FCat -> (FRulesEnv, FCat)
genFCatArg ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) = genFCatArg ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =
case Map.lookup cat fcatSet >>= Map.lookup rcs of case Map.lookup cat fcatSet >>= Map.lookup rcs of
Just tmap -> case Map.lookup tcs tmap of Just tmap -> case Map.lookup tcs tmap of
@@ -281,13 +262,13 @@ genFCatArg ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =
(x_fcat,last_id1,tmap1,rules1) (x_fcat,last_id1,tmap1,rules1)
= foldBM (\tcs st (x_fcat,last_id,tmap,rules) -> = foldBM (\tcs st (x_fcat,last_id,tmap,rules) ->
let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap
rule = FRule (Abs fcat [fcat_arg] coercionName) rule = FRule (Name (CId "_") [Unify [0]]) [fcat_arg] fcat
(listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]]) (listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]])
in if st in if st
then (Right fcat,last_id1,tmap1,rule:rules) then (Right fcat,last_id1,tmap1,rule:rules)
else (x_fcat, last_id, tmap, rules)) else (x_fcat, last_id, tmap, rules))
(Left fcat,next_id,Map.insert tcs x_fcat tmap,rules) (Left fcat,next_id,Map.insert tcs x_fcat tmap,rules)
(gen_tcs ctype emptyPath []) (gen_tcs ctype [] [])
False False
rmap1 = Map.singleton rcs tmap1 rmap1 = Map.singleton rcs tmap1
in (FRulesEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 fcatSet) rules1, fcat) in (FRulesEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 fcatSet) rules1, fcat)
@@ -300,22 +281,22 @@ genFCatArg ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =
fcat = FCat next_id cat rcs tcs fcat = FCat next_id cat rcs tcs
in (next_id, Map.insert tcs (Left fcat) tmap, fcat) in (next_id, Map.insert tcs (Left fcat) tmap, fcat)
gen_tcs :: SLinType -> SPath -> [(SPath,STerm)] -> BacktrackM Bool [(SPath,STerm)] gen_tcs :: Term -> FPath -> [(FPath,FIndex)] -> BacktrackM Bool [(FPath,FIndex)]
gen_tcs (RecT record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (path ++. label) acc) acc record gen_tcs (R record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (label:path) acc) acc (zip [0..] record)
gen_tcs (TblT terms ctype) path acc = foldM (\acc term -> gen_tcs ctype (path ++! term ) acc) acc terms gen_tcs (S _) path acc = return acc
gen_tcs (StrT) path acc = return acc gen_tcs (RP alias _) path acc = gen_tcs alias path acc
gen_tcs (ConT terms) path acc = gen_tcs (C max_index) path acc =
case List.lookup path tcs of case List.lookup path tcs of
Just term -> return $! addConstraint path term acc Just index -> return $! addConstraint path index acc
Nothing -> do writeState True Nothing -> do writeState True
term <- member terms index <- member [0..max_index-1]
return $! addConstraint path term acc return $! addConstraint path index acc
where where
addConstraint path0 term0 (c@(path,term) : cs) addConstraint path0 index0 (c@(path,index) : cs)
| path0 > path = c:addConstraint path0 term0 cs | path0 > path = c:addConstraint path0 index0 cs
addConstraint path0 term0 cs = (path0,term0) : cs addConstraint path0 index0 cs = (path0,index0) : cs
takeToDoRules :: SRulesMap -> FRulesEnv -> ([([SRule], STermSelector)], FRulesEnv) takeToDoRules :: XRulesMap -> FRulesEnv -> ([([XRule], TermSelector)], FRulesEnv)
takeToDoRules srulesMap (FRulesEnv last_id fcatSet rules) = (todo,FRulesEnv last_id fcatSet' rules) takeToDoRules srulesMap (FRulesEnv last_id fcatSet rules) = (todo,FRulesEnv last_id fcatSet' rules)
where where
(todo,fcatSet') = (todo,fcatSet') =
@@ -343,97 +324,82 @@ getFRules (FRulesEnv last_id fcatSet rules) = rules
------------------------------------------------------------ ------------------------------------------------------------
-- The STermSelector -- The TermSelector
data STermSelector data TermSelector
= RecSel [(Label, STermSelector)] = TupleSel [(FIndex, TermSelector)]
| TblSel [(STerm, STermSelector)] | TuplePrj FIndex TermSelector
| RecPrj Label STermSelector | ConSel [FIndex]
| TblPrj STerm STermSelector
| ConSel [STerm]
| StrSel | StrSel
deriving Show
mkSingletonSelectors :: SLinType -> [STermSelector] mkSingletonSelectors :: Term -- ^ Type representation term
mkSingletonSelectors ctype = sels0 -> [TermSelector] -- ^ list of selectors containing just one string field
mkSingletonSelectors term = sels0
where where
(sels0,tcss0) = loop emptyPath ([],[]) ctype (sels0,tcss0) = loop [] ([],[]) term
loop path st (RecT record) = List.foldl' (\st (lbl,ctype) -> loop (path ++. lbl ) st ctype) st record
loop path st (TblT terms ctype) = List.foldl' (\st term -> loop (path ++! term) st ctype) st terms
loop path (sels,tcss) (ConT terms) = ( sels,map ((,) path) terms : tcss)
loop path (sels,tcss) (StrT) = (mkSelector [path] tcss0 : sels, tcss)
loop path st (R record) = List.foldl' (\st (index,term) -> loop (index:path) st term) st (zip [0..] record)
loop path st (RP t _) = loop path st t
loop path (sels,tcss) (C i) = ( sels,map ((,) path) [0..i-1] : tcss)
loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss)
mkSelector :: [SPath] -> [[(SPath,STerm)]] -> STermSelector mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector
mkSelector rcs tcss = mkSelector rcs tcss =
List.foldl' addRestriction (case xs of List.foldl' addRestriction (case xs of
(path:xs) -> List.foldl' addProjection (path2selector StrSel path) xs) ys (path:xs) -> List.foldl' addProjection (path2selector StrSel path) xs) ys
where where
xs = [ reverse path | Path path <- rcs] xs = [ reverse path | path <- rcs]
ys = [(reverse path,term) | tcs <- tcss, (Path path,term) <- tcs] ys = [(reverse path,term) | tcs <- tcss, (path,term) <- tcs]
addProjection :: STermSelector -> [Either Label STerm] -> STermSelector addRestriction :: TermSelector -> (FPath,FIndex) -> TermSelector
addProjection StrSel [] = StrSel addRestriction (ConSel indices) ([] ,n_index) = ConSel (add indices)
addProjection (RecSel fields) (Left lbl : path) = RecSel (add fields)
where where
add [] = [(lbl,path2selector StrSel path)] add [] = [n_index]
add (field@(lbl',sub_sel):fields) add (index':indices)
| lbl == lbl' = (lbl',addProjection sub_sel path):fields | n_index == index' = index': indices
| otherwise = index':add indices
addRestriction (TupleSel fields) (index : path,n_index) = TupleSel (add fields)
where
add [] = [(index,path2selector (ConSel [n_index]) path)]
add (field@(index',sub_sel):fields)
| index == index' = (index',addRestriction sub_sel (path,n_index)):fields
| otherwise = field : add fields | otherwise = field : add fields
addProjection (TblSel cases) (Right pat : path) = TblSel (add cases)
where
add [] = [(pat,path2selector StrSel path)]
add (cas@(pat',sub_sel):cases)
| pat == pat' = (pat',addProjection sub_sel path):cases
| otherwise = cas : add cases
addRestriction :: STermSelector -> ([Either Label STerm],STerm) -> STermSelector addProjection :: TermSelector -> FPath -> TermSelector
addRestriction (ConSel terms) ([] ,term) = ConSel (add terms) addProjection StrSel [] = StrSel
addProjection (TupleSel fields) (index : path) = TupleSel (add fields)
where where
add [] = [term] add [] = [(index,path2selector StrSel path)]
add (term':terms) add (field@(index',sub_sel):fields)
| term == term' = term': terms | index == index' = (index',addProjection sub_sel path):fields
| otherwise = term':add terms
addRestriction (RecSel fields) (Left lbl : path,term) = RecSel (add fields)
where
add [] = [(lbl,path2selector (ConSel [term]) path)]
add (field@(lbl',sub_sel):fields)
| lbl == lbl' = (lbl',addRestriction sub_sel (path,term)):fields
| otherwise = field : add fields | otherwise = field : add fields
addRestriction (TblSel cases) (Right pat : path,term) = TblSel (add cases)
where path2selector base [] = base
add [] = [(pat,path2selector (ConSel [term]) path)] path2selector base (index : path) = TupleSel [(index,path2selector base path)]
add (field@(pat',sub_sel):cases)
| pat == pat' = (pat',addRestriction sub_sel (path,term)):cases
| otherwise = field : add cases
path2selector base [] = base
path2selector base (Left lbl : path) = RecSel [(lbl,path2selector base path)]
path2selector base (Right sel : path) = TblSel [(sel,path2selector base path)]
------------------------------------------------------------ ------------------------------------------------------------
-- updating the MCF rule -- updating the MCF rule
readArgCType :: Int -> CnvMonad SLinType readArgCType :: FIndex -> CnvMonad Term
readArgCType arg = do (_, _, _, ctypes) <- readState readArgCType nr = do (_, _, _, ctypes) <- readState
return (ctypes !! arg) return (ctypes !! fromIntegral nr)
restrictArg :: Int -> SPath -> STerm -> CnvMonad () restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad ()
restrictArg nr path term = do restrictArg nr path index = do
(head, args, ctype, ctypes) <- readState (head, args, ctype, ctypes) <- readState
args' <- updateNthM (\(fcat,xs) -> do fcat <- restrictFCat path term fcat args' <- updateNthM (\(fcat,xs) -> do fcat <- restrictFCat path index fcat
return (fcat,xs) ) nr args return (fcat,xs) ) (fromIntegral nr) args
writeState (head, args', ctype, ctypes) writeState (head, args', ctype, ctypes)
projectArg :: Int -> SPath -> CnvMonad Int projectArg :: FIndex -> FPath -> CnvMonad Int
projectArg nr path = do projectArg nr path = do
(head, args, ctype, ctypes) <- readState (head, args, ctype, ctypes) <- readState
(xnr,args') <- updateArgs nr args (xnr,args') <- updateArgs nr args
writeState (head, args', ctype, ctypes) writeState (head, args', ctype, ctypes)
return xnr return xnr
where where
updateArgs :: Int -> [(FCat,[SPath])] -> CnvMonad (Int,[(FCat,[SPath])]) updateArgs :: FIndex -> [(FCat,[FPath])] -> CnvMonad (Int,[(FCat,[FPath])])
updateArgs 0 ((a@(FCat _ _ rcs _),xpaths) : as) updateArgs 0 ((a@(FCat _ _ rcs _),xpaths) : as)
| path `elem` rcs = return (length xpaths+1,(a,path:xpaths):as) | path `elem` rcs = return (length xpaths+1,(a,path:xpaths):as)
| otherwise = do a <- projectFCat path a | otherwise = do a <- projectFCat path a
@@ -442,34 +408,34 @@ projectArg nr path = do
(xnr,as) <- updateArgs (n-1) as (xnr,as) <- updateArgs (n-1) as
return (xnr,a:as) return (xnr,a:as)
readHeadCType :: CnvMonad SLinType readHeadCType :: CnvMonad Term
readHeadCType = do (_, _, ctype, _) <- readState readHeadCType = do (_, _, ctype, _) <- readState
return ctype return ctype
restrictHead :: SPath -> STerm -> CnvMonad () restrictHead :: FPath -> FIndex -> CnvMonad ()
restrictHead path term restrictHead path term
= do (head, args, ctype, ctypes) <- readState = do (head, args, ctype, ctypes) <- readState
head' <- restrictFCat path term head head' <- restrictFCat path term head
writeState (head', args, ctype, ctypes) writeState (head', args, ctype, ctypes)
projectHead :: SPath -> CnvMonad () projectHead :: FPath -> CnvMonad ()
projectHead path projectHead path
= do (head, args, ctype, ctypes) <- readState = do (head, args, ctype, ctypes) <- readState
head' <- projectFCat path head head' <- projectFCat path head
writeState (head', args, ctype, ctypes) writeState (head', args, ctype, ctypes)
restrictFCat :: SPath -> STerm -> FCat -> CnvMonad FCat restrictFCat :: FPath -> FIndex -> FCat -> CnvMonad FCat
restrictFCat path0 term0 (FCat id cat rcs tcs) = do restrictFCat path0 index0 (FCat id cat rcs tcs) = do
tcs <- addConstraint tcs tcs <- addConstraint tcs
return (FCat id cat rcs tcs) return (FCat id cat rcs tcs)
where where
addConstraint (c@(path,term) : cs) addConstraint (c@(path,index) : cs)
| path0 > path = liftM (c:) (addConstraint cs) | path0 > path = liftM (c:) (addConstraint cs)
| path0 == path = guard (term0 == term) >> | path0 == path = guard (index0 == index) >>
return (c : cs) return (c : cs)
addConstraint cs = return ((path0,term0) : cs) addConstraint cs = return ((path0,index0) : cs)
projectFCat :: SPath -> FCat -> CnvMonad FCat projectFCat :: FPath -> FCat -> CnvMonad FCat
projectFCat path0 (FCat id cat rcs tcs) = do projectFCat path0 (FCat id cat rcs tcs) = do
return (FCat id cat (addConstraint rcs) tcs) return (FCat id cat (addConstraint rcs) tcs)
where where

34
src/GF/Conversion/Types.hs
View File

@@ -16,8 +16,8 @@ module GF.Conversion.Types where
import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent) import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..)) import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..))
import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC (CId(..))
import qualified GF.Grammar.Grammar as Grammar (Term) import qualified GF.Grammar.Grammar as Grammar (Term)
import qualified GF.Grammar.Values as Values (cString, cInt, cFloat)
import GF.Formalism.GCFG import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC import GF.Formalism.SimpleGFC
@@ -110,19 +110,22 @@ mcat2scat = ecat2scat . mcat2ecat
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- * fast nonerasing MCFG -- * fast nonerasing MCFG
type FGrammar = FCFGrammar FCat Name Token type FIndex = Int
type FRule = FCFRule FCat Name Token type FPath = [FIndex]
data FCat = FCat {-# UNPACK #-} !Int SCat [SPath] [(SPath,STerm)] type FName = NameProfile AbsGFCC.CId
type FGrammar = FCFGrammar FCat FName Token
type FRule = FCFRule FCat FName Token
data FCat = FCat {-# UNPACK #-} !Int AbsGFCC.CId [FPath] [(FPath,FIndex)]
initialFCat :: SCat -> FCat initialFCat :: AbsGFCC.CId -> FCat
initialFCat cat = FCat 0 cat [] [] initialFCat cat = FCat 0 cat [] []
fcatString = FCat (-1) Values.cString [Path [Left (AbsGFC.L (Ident.IC "s"))]] [] fcatString = FCat (-1) (AbsGFCC.CId "String") [[0]] []
fcatInt = FCat (-2) Values.cInt [Path [Left (AbsGFC.L (Ident.IC "s"))]] [] fcatInt = FCat (-2) (AbsGFCC.CId "Int") [[0]] []
fcatFloat = FCat (-3) Values.cFloat [Path [Left (AbsGFC.L (Ident.IC "s"))]] [] fcatFloat = FCat (-3) (AbsGFCC.CId "Float") [[0]] []
fcat2scat :: FCat -> SCat fcat2cid :: FCat -> AbsGFCC.CId
fcat2scat (FCat _ c _ _) = c fcat2cid (FCat _ c _ _) = c
instance Eq FCat where instance Eq FCat where
(FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2 (FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2
@@ -130,6 +133,9 @@ instance Eq FCat where
instance Ord FCat where instance Ord FCat where
compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2 compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2
instance Print AbsGFCC.CId where
prt (AbsGFCC.CId s) = s
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- * CFG -- * CFG
@@ -158,8 +164,8 @@ instance Print CCat where
prt (CCat cat label) = prt cat ++ prt label prt (CCat cat label) = prt cat ++ prt label
instance Print FCat where instance Print FCat where
prt (FCat _ cat rcs tcs) = prt cat ++ "{" ++ prt (FCat _ (AbsGFCC.CId cat) rcs tcs) = cat ++ "{" ++
prtSep ";" ([prt path | path <- rcs] ++ prtSep ";" ([prt path | path <- rcs] ++
[prt path ++ "=" ++ prt term | (path,term) <- tcs]) [prt path ++ "=" ++ prt term | (path,term) <- tcs])
++ "}" ++ "}"

5
src/GF/FCFG/ToFCFG.hs
View File

@@ -30,8 +30,8 @@ import GF.Infra.Print
-- this is the main function used -- this is the main function used
printFGrammar :: FCFGrammar FCat Name Token -> String printFGrammar :: FCFGrammar FCat FName Token -> String
printFGrammar = printTree . fgrammar printFGrammar = undefined {- printTree . fgrammar
fgrammar :: FCFGrammar FCat Name Token -> F.FGrammar fgrammar :: FCFGrammar FCat Name Token -> F.FGrammar
fgrammar = F.FGr . map frule fgrammar = F.FGr . map frule
@@ -98,3 +98,4 @@ ident :: Ident -> F.Ident
ident = F.Ident . prIdent --- is information lost? ident = F.Ident . prIdent --- is information lost?
constr (C.CIQ m c) = F.CIQ (ident m) (ident c) constr (C.CIQ m c) = F.CIQ (ident m) (ident c)
-}

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

@@ -30,13 +30,13 @@ data FSymbol cat tok
| FSymTok tok | FSymTok tok
type FCFGrammar cat name tok = [FCFRule cat name tok] type FCFGrammar cat name tok = [FCFRule cat name tok]
data FCFRule cat name tok = FRule (Abstract cat name) (Array FLabel (Array FPointPos (FSymbol cat tok))) data FCFRule cat name tok = FRule name [cat] cat (Array FLabel (Array FPointPos (FSymbol cat tok)))
------------------------------------------------------------ ------------------------------------------------------------
-- pretty-printing -- pretty-printing
instance (Print c, Print t) => Print (FSymbol c t) where instance (Print c, Print t) => Print (FSymbol c t) where
prt (FSymCat c l n) = prt c ++ "[" ++ prt n ++ "," ++ prt l ++ "]" prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")"
prt (FSymTok t) = simpleShow (prt t) prt (FSymTok t) = simpleShow (prt t)
where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\"" where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\""
mkEsc '\\' = "\\\\" mkEsc '\\' = "\\\\"
@@ -47,5 +47,6 @@ instance (Print c, Print t) => Print (FSymbol c t) where
prtList = prtSep " " prtList = prtSep " "
instance (Print c, Print n, Print t) => Print (FCFRule n c t) where instance (Print c, Print n, Print t) => Print (FCFRule n c t) where
prt (FRule abs lins) = prt abs ++ " := \n" ++ prtSep "\n" [" | "++prtSep " " [prt sym | (_,sym) <- assocs syms] | (_,syms) <- assocs lins] prt (FRule name args res lins) = prt name ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++
" =\n [" ++ prtSep "\n " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs lins]++"]"
prtList = prtSep "\n" prtList = prtSep "\n"

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

@@ -23,12 +23,12 @@ import GF.Infra.Print
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- parsing -- parsing
parseFCF :: (Print c, Ord c, Print n, Ord n, Print t, Ord t) => String -> Err (FCFParser c n t) parseFCF :: (Print c, Ord c, Ord n, Print t, Ord t) => String -> Err (FCFParser c n t)
parseFCF prs | prs `elem` strategies = Ok $ parseFCF' prs parseFCF prs | prs `elem` strategies = Ok $ parseFCF' prs
| otherwise = Bad $ "FCFG parsing strategy not defined: " ++ prs | otherwise = Bad $ "FCFG parsing strategy not defined: " ++ prs
strategies = words "bottomup topdown" strategies = words "bottomup topdown"
parseFCF' :: (Print c, Ord c, Print n, Ord n, Print t, Ord t) => String -> FCFParser c n t parseFCF' :: (Print c, Ord c, Ord n, Print t, Ord t) => String -> FCFParser c n t
parseFCF' "bottomup" pinfo starts toks = Active.parse "b" pinfo starts toks parseFCF' "bottomup" pinfo starts toks = Active.parse "b" pinfo starts toks
parseFCF' "topdown" pinfo starts toks = Active.parse "t" pinfo starts toks parseFCF' "topdown" pinfo starts toks = Active.parse "t" pinfo starts toks

23
src/GF/Parsing/FCFG/Active.hs
View File

@@ -20,6 +20,7 @@ import GF.Formalism.MCFG(Lin(..))
import GF.Formalism.Utilities import GF.Formalism.Utilities
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Print
import GF.Parsing.FCFG.Range import GF.Parsing.FCFG.Range
import GF.Parsing.FCFG.PInfo import GF.Parsing.FCFG.PInfo
@@ -34,7 +35,7 @@ import Data.Array
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- * parsing -- * parsing
parse :: (Ord c, Ord n, Ord t) => String -> FCFParser c n t parse :: (Print c, Ord c, Ord n, Print t, Ord t) => String -> FCFParser c n t
parse strategy pinfo starts toks = xchart2syntaxchart chart pinfo parse strategy pinfo starts toks = xchart2syntaxchart chart pinfo
where chart = process strategy pinfo toks axioms emptyXChart where chart = process strategy pinfo toks axioms emptyXChart
axioms | isBU strategy = literals pinfo toks ++ initialBU pinfo toks axioms | isBU strategy = literals pinfo toks ++ initialBU pinfo toks
@@ -47,7 +48,7 @@ isTD s = s=="t"
emptyChildren :: RuleId -> FCFPInfo c n t -> SyntaxNode RuleId RangeRec emptyChildren :: RuleId -> FCFPInfo c n t -> SyntaxNode RuleId RangeRec
emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) []) emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) [])
where where
FRule (Abs _ rhs _) _ = allRules pinfo ! ruleid FRule _ rhs _ _ = allRules pinfo ! ruleid
updateChildren :: SyntaxNode RuleId RangeRec -> Int -> RangeRec -> [SyntaxNode RuleId RangeRec] updateChildren :: SyntaxNode RuleId RangeRec -> Int -> RangeRec -> [SyntaxNode RuleId RangeRec]
updateChildren (SNode ruleid recs) i rec = do updateChildren (SNode ruleid recs) i rec = do
@@ -59,7 +60,7 @@ updateChildren (SNode ruleid recs) i rec = do
makeMaxRange (Range _ j) = Range j j makeMaxRange (Range _ j) = Range j j
makeMaxRange EmptyRange = EmptyRange makeMaxRange EmptyRange = EmptyRange
process :: (Ord c, Ord n, Ord t) => String -> FCFPInfo c n t -> Input t -> [(c,Item)] -> XChart c -> XChart c process :: (Print c, Ord c, Ord n, Print t, Ord t) => String -> FCFPInfo c n t -> Input t -> [(c,Item)] -> XChart c -> XChart c
process strategy pinfo toks [] chart = chart process strategy pinfo toks [] chart = chart
process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks items $! univRule c item chart process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks items $! univRule c item chart
where where
@@ -86,22 +87,22 @@ process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks
then univRule cat (Active (rng:found) EmptyRange (lbl+1) 0 node) chart then univRule cat (Active (rng:found) EmptyRange (lbl+1) 0 node) chart
else univRule cat (Final (reverse (rng:found)) node) chart else univRule cat (Final (reverse (rng:found)) node) chart
where where
(FRule (Abs cat _ fn) lins) = allRules pinfo ! ruleid (FRule fn _ cat lins) = allRules pinfo ! ruleid
lin = lins ! lbl lin = lins ! lbl
univRule cat item@(Final found' node) chart = univRule cat item@(Final found' node) chart =
case insertXChart chart item cat of case insertXChart chart item cat of
Nothing -> chart Nothing -> chart
Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat
let FRule _ lins = allRules pinfo ! ruleid let FRule _ _ _ lins = allRules pinfo ! ruleid
FSymCat cat r d = lins ! l ! ppos FSymCat cat r d = lins ! l ! ppos
rng <- concatRange rng (found' !! r) rng <- concatRange rng (found' !! r)
node <- updateChildren node d found' node <- updateChildren node d found'
return (cat, Active found rng l (ppos+1) node) return (cat, Active found rng l (ppos+1) node)
++ ++
do guard (isBU strategy) do guard (isBU strategy)
ruleid <- leftcornerCats pinfo ? cat ruleid <- leftcornerCats pinfo ? cat
let FRule _ lins = allRules pinfo ! ruleid let FRule _ _ _ lins = allRules pinfo ! ruleid
FSymCat cat r d = lins ! 0 ! 0 FSymCat cat r d = lins ! 0 ! 0
node <- updateChildren (emptyChildren ruleid pinfo) d found' node <- updateChildren (emptyChildren ruleid pinfo) d found'
return (cat, Active [] (found' !! r) 0 1 node) return (cat, Active [] (found' !! r) 0 1 node)
in process strategy pinfo toks items chart in process strategy pinfo toks items chart
@@ -140,7 +141,7 @@ xchart2syntaxchart :: (Ord c, Ord n, Ord t) => XChart c -> FCFPInfo c n t -> Syn
xchart2syntaxchart (XChart actives finals) pinfo = xchart2syntaxchart (XChart actives finals) pinfo =
accumAssoc groupSyntaxNodes $ accumAssoc groupSyntaxNodes $
[ case node of [ case node of
SNode ruleid rrecs -> let FRule (Abs cat rhs fun) _ = allRules pinfo ! ruleid SNode ruleid rrecs -> let FRule fun rhs cat _ = allRules pinfo ! ruleid
in ((cat,found), SNode fun (zip rhs rrecs)) in ((cat,found), SNode fun (zip rhs rrecs))
SString s -> ((cat,found), SString s) SString s -> ((cat,found), SString s)
SInt n -> ((cat,found), SInt n) SInt n -> ((cat,found), SInt n)
@@ -171,5 +172,5 @@ initialBU pinfo toks =
do tok <- aElems (inputToken toks) do tok <- aElems (inputToken toks)
ruleid <- leftcornerTokens pinfo ? tok ++ ruleid <- leftcornerTokens pinfo ? tok ++
epsilonRules pinfo epsilonRules pinfo
let FRule (Abs cat _ _) _ = allRules pinfo ! ruleid let FRule _ _ cat _ = allRules pinfo ! ruleid
return (cat,Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo)) return (cat,Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo))

12
src/GF/Parsing/FCFG/PInfo.hs
View File

@@ -87,18 +87,18 @@ buildFCFPInfo lexer grammar =
} }
where allrules = listArray (0,length grammar-1) grammar where allrules = listArray (0,length grammar-1) grammar
topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule (Abs cat _ _) _) <- assocs allrules] topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ cat _) <- assocs allrules]
-- emptyrules = [ruleid | (ruleid, FRule (Abs _ [] _) _) <- assocs allrules] -- emptyrules = [ruleid | (ruleid, FRule _ [] _ _) <- assocs allrules]
epsilonrules = [ ruleid | (ruleid, FRule _ lins) <- assocs allrules, epsilonrules = [ ruleid | (ruleid, FRule _ _ _ lins) <- assocs allrules,
not (inRange (bounds (lins ! 0)) 0) ] not (inRange (bounds (lins ! 0)) 0) ]
leftcorncats = accumAssoc id leftcorncats = accumAssoc id
[ (fromJust (getLeftCornerCat lins), ruleid) | [ (fromJust (getLeftCornerCat lins), ruleid) |
(ruleid, FRule _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ] (ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ]
leftcorntoks = accumAssoc id leftcorntoks = accumAssoc id
[ (fromJust (getLeftCornerTok lins), ruleid) | [ (fromJust (getLeftCornerTok lins), ruleid) |
(ruleid, FRule _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ] (ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ]
grammarcats = aElems topdownrules grammarcats = aElems topdownrules
grammartoks = nubsort [t | (FRule _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin] grammartoks = nubsort [t | (FRule _ _ _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin]
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- pretty-printing of statistics -- pretty-printing of statistics

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

@@ -24,6 +24,7 @@ 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.Infra.Ident as Ident import qualified GF.Infra.Ident as Ident
import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok) import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok)
@@ -49,7 +50,7 @@ data PInfo = PInfo { mcfPInfo :: MCFPInfo
} }
type MCFPInfo = PM.MCFPInfo MCat Name MLabel Token type MCFPInfo = PM.MCFPInfo MCat Name MLabel Token
type FCFPInfo = PF.FCFPInfo FCat Name Token type FCFPInfo = PF.FCFPInfo FCat FName Token
type CFPInfo = PC.CFPInfo CCat Name Token type CFPInfo = PC.CFPInfo CCat Name Token
buildPInfo :: MGrammar -> FGrammar -> CGrammar -> PInfo buildPInfo :: MGrammar -> FGrammar -> CGrammar -> PInfo
@@ -128,17 +129,33 @@ selectParser "m" strategy pinfo startCat inTokens
-- parsing via FCFG -- parsing via FCFG
selectParser "f" strategy pinfo startCat inTokens selectParser "f" strategy pinfo startCat inTokens
= do let startCats = filter isStart $ PF.grammarCats fcfpi = do let startCats = filter isStart $ PF.grammarCats fcfpi
isStart cat = fcat2scat cat == cfCat2Ident startCat isStart cat = cat' == cfCat2Ident startCat
where AbsGFCC.CId x = fcat2cid cat
cat' = Ident.IC x
fcfpi = fcfPInfo pinfo fcfpi = fcfPInfo pinfo
fcfParser <- PF.parseFCF strategy fcfParser <- PF.parseFCF strategy
let chart = fcfParser fcfpi startCats inTokens let chart = fcfParser fcfpi startCats inTokens
(i,j) = inputBounds inTokens (i,j) = inputBounds inTokens
finalEdges = [PF.makeFinalEdge cat i j | cat <- startCats] finalEdges = [PF.makeFinalEdge cat i j | cat <- startCats]
return $ chart2forests chart (const False) finalEdges return $ map cnv_forests $ chart2forests chart (const False) finalEdges
-- error parser: -- error parser:
selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with strategy: " ++ strategy selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with strategy: " ++ strategy
cnv_forests FMeta = FMeta
cnv_forests (FNode (Name (AbsGFCC.CId n) p) fss) = FNode (Name (Ident.IC n) (map cnv_profile p)) (map (map cnv_forests) fss)
cnv_forests (FString x) = FString x
cnv_forests (FInt x) = FInt x
cnv_forests (FFloat x) = FFloat x
cnv_profile (Unify x) = Unify x
cnv_profile (Constant x) = Constant (cnv_forests2 x)
cnv_forests2 FMeta = FMeta
cnv_forests2 (FNode (AbsGFCC.CId n) fss) = FNode (Ident.IC n) (map (map cnv_forests2) fss)
cnv_forests2 (FString x) = FString x
cnv_forests2 (FInt x) = FInt x
cnv_forests2 (FFloat x) = FFloat x
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- parse trees to GF terms -- parse trees to GF terms

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

@@ -298,7 +298,6 @@ customGrammarPrinter =
,(strCI "mcfg", \_ -> Prt.prt . stateMCFG) ,(strCI "mcfg", \_ -> Prt.prt . stateMCFG)
,(strCI "fcfg", \_ -> Prt.prt . stateFCFG) ,(strCI "fcfg", \_ -> Prt.prt . stateFCFG)
,(strCI "bfcfg", \_ -> printFGrammar . stateFCFG) ,(strCI "bfcfg", \_ -> printFGrammar . stateFCFG)
,(strCI "mcfg2fcfg",\_ -> Prt.prt . Cnv.mcfg2fcfg . stateMCFG)
,(strCI "cfg", \_ -> Prt.prt . stateCFG) ,(strCI "cfg", \_ -> Prt.prt . stateCFG)
,(strCI "pinfo", \_ -> Prt.prt . statePInfo) ,(strCI "pinfo", \_ -> Prt.prt . statePInfo)
,(strCI "abstract", \_ -> Prt.prtAfter "\n" . Cnv.gfc2abstract . stateGrammarLang) ,(strCI "abstract", \_ -> Prt.prtAfter "\n" . Cnv.gfc2abstract . stateGrammarLang)