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.Canon.GFC
import GF.Canon.AbsGFC
import GF.Canon.CanonToGFCC as C2GFCC
import GF.Grammar.Macros
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.Conversion.GFC as Cnv
import qualified GF.Conversion.SimpleToFCFG as FCnv
import qualified GF.Parsing.GFC as Prs
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) $
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)
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
Ok mo -> not $ isIncompleteCanon (m,mo)
_ -> 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
notInrts f = notElem f $ map fst rts
subcgr = unSubelimCanon cgr
@@ -252,9 +258,12 @@ updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
let probss = [] -----
let fromGFC = snd . snd . Cnv.convertGFC opts
(mcfgs, fcfgs, cfgs) = unzip3 $ map (curry fromGFC cgr) concrs
pInfos = zipWith3 Prs.buildPInfo mcfgs fcfgs cfgs
let fromGFC = snd . snd . Cnv.convertGFC opts
(mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs
fcfgs = FCnv.convertGrammar (C2GFCC.mkCanon2gfcc cgr)
pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs
let funs = funRulesOf cgr
let cats = allCatsOf cgr
@@ -273,9 +282,9 @@ updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
canModules = cgr,
srcModules = src,
cfs = cf's,
abstracts = abstrs,
abstracts = maybe [] (\a -> [(a,concrs)]) abstr0,
mcfgs = zip concrs mcfgs,
fcfgs = zip concrs fcfgs,
fcfgs = fcfgs,
cfgs = zip concrs cfgs,
pInfos = zip concrs pInfos,
morphos = morphs,

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

@@ -18,6 +18,7 @@ module GF.Conversion.GFC
import GF.Infra.Option
import GF.Canon.GFC (CanonGrammar)
import GF.Infra.Ident (Ident, identC)
import qualified GF.Infra.Modules as M
import GF.Formalism.GCFG (Rule(..), Abstract(..))
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.RemoveEpsilon as RemEps
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 GF.Infra.Print
import GF.System.Tracing
import qualified Debug.Trace as D
----------------------------------------------------------------------
-- * GFC -> MCFG & CFG, using options to decide which conversion is used
convertGFC :: Options -> (CanonGrammar, Ident)
-> (SGrammar, (EGrammar, (MGrammar, FGrammar, CGrammar)))
convertGFC :: Options -> (CanonGrammar, Ident)
-> (SGrammar, (EGrammar, (MGrammar, CGrammar)))
convertGFC opts = \g -> let s = g2s g
e = s2e s
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
e2m = case getOptVal opts firstCat of
Just cat -> flip erasing [identC cat]
@@ -57,8 +57,6 @@ convertGFC opts = \g -> let s = g2s g
Just "finite-strict" -> strict
Just "epsilon" -> epsilon . nondet
_ -> nondet
s2fm= S2FM.convertGrammar
m2fm= undefined --M2FM.convertGrammar
g2s = case getOptVal opts gfcConversion of
Just "finite" -> finite . simple
Just "finite2" -> finite . finite . simple
@@ -82,20 +80,12 @@ gfc2simple opts = fst . convertGFC opts
gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar
gfc2mcfg opts g = mcfg
where
(mcfg, _, _) = snd (snd (convertGFC opts g))
(mcfg, _) = snd (snd (convertGFC opts g))
gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar
gfc2cfg opts g = cfg
where
(_, _, 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
(_, cfg) = snd (snd (convertGFC opts g))
----------------------------------------------------------------------

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

@@ -22,11 +22,10 @@ import GF.Infra.Ident
import Control.Monad
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.FCFG
import GF.Formalism.SimpleGFC
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.SortedList
@@ -36,40 +35,47 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
import Data.Array
import Data.Maybe
----------------------------------------------------------------------
-- main conversion function
convertGrammar :: SGrammar -> FGrammar
convertGrammar srules = getFRules (loop frulesEnv)
convertGrammar :: Grammar -> [(Ident,FGrammar)]
convertGrammar g@(Grm hdr (Abs abs_defs) cncs) = [(i2i cncname,convert abs_defs conc) | cncname <- cncnames gfcc, conc <- Map.lookup cncname (concretes gfcc)]
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
helper (srulesMap,frulesEnv) rule@(Rule (Abs decl _ _) (Cnc ctype _ _)) =
let srulesMap' = Map.insertWith (++) (decl2cat decl) [rule] srulesMap
frulesEnv' = List.foldl' (\env selector -> convertRule selector rule env)
frulesEnv
(mkSingletonSelectors ctype)
in srulesMap' `seq` frulesEnv' `seq` (srulesMap',frulesEnv')
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]
findLinType (CId id) = fromJust (Map.lookup (CId ("__"++id)) cnc_defs)
loop frulesEnv =
let (todo, frulesEnv') = takeToDoRules srulesMap frulesEnv
in case todo of
[] -> frulesEnv'
_ -> loop $! List.foldl' (\env (srules,selector) ->
List.foldl' (\env srule -> convertRule selector srule env) env srules) frulesEnv' todo
(srulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules
where
helper (srulesMap,frulesEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) =
let srulesMap' = Map.insertWith (++) abs_res [rule] srulesMap
frulesEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env)
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
----------------------------------------------------------------------
-- rule conversion
convertRule :: STermSelector -> SRule -> FRulesEnv -> FRulesEnv
convertRule selector (Rule (Abs decl decls (Name fun profile)) (Cnc ctype ctypes (Just term))) frulesEnv =
convertRule :: TermMap -> TermSelector -> XRule -> FRulesEnv -> FRulesEnv
convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) frulesEnv =
foldBM addRule
frulesEnv
(convertTerm selector term [Lin emptyPath []])
(let cat : args = map decl2cat (decl : decls)
in (initialFCat cat, map (\scat -> (initialFCat scat,[])) args, ctype, ctypes))
(convertTerm cnc_defs selector term [([],[])])
(initialFCat cat, map (\scat -> (initialFCat scat,[])) args, ctype, ctypes)
where
addRule linRec (newCat', newArgs', _, _) env0 =
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
FCat _ _ [] _ -> (env , args, all_args)
_ -> (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}]
(_,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])
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
convertRule selector _ frulesEnv = frulesEnv
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)
| otherwise = translateLin idxArgs lbl' lins
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)
| nr == idx = let arg@(FCat _ _ rcs _) = xargs !! xnr
in FSymCat arg (index lbl rcs 0) (nr'+xnr)
@@ -107,139 +112,115 @@ translateLin idxArgs lbl' (Lin lbl syms : lins)
| lbl' == lbl = idx
| otherwise = index lbl' lbls $! (idx+1)
----------------------------------------------------------------------
-- term conversion
type CnvMonad a = BacktrackM Env a
type Env = (FCat, [(FCat,[SPath])], SLinType, [SLinType])
type LinRec = [Lin SCat SPath Token]
type Env = (FCat, [(FCat,[FPath])], Term, [Term])
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
convertTerm selector (Arg nr cat path) (Lin lbl_path lin : lins) = convertArg selector nr cat path lbl_path lin lins
convertTerm selector (con :^ args) (Lin lbl_path lin : lins) = convertCon selector con args lbl_path lin lins
convertTerm selector (Rec record) (Lin lbl_path lin : lins) = convertRec selector record lbl_path lin lins
convertTerm selector (term :. lbl) lins = convertTerm (RecPrj lbl selector) term lins
convertTerm selector (Tbl table) (Lin lbl_path lin : lins) = convertTbl selector table lbl_path lin lins
convertTerm selector (term :! sel) lins = do sel <- evalTerm sel
convertTerm (TblPrj sel selector) term lins
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
convertArg (TupleSel record) nr path lbl_path lin lins =
foldM (\lins (lbl, selector) -> convertArg selector nr (lbl:path) (lbl:lbl_path) lin lins) lins record
convertArg (TuplePrj lbl selector) nr path lbl_path lin lins =
convertArg selector nr (lbl:path) lbl_path lin lins
convertArg (ConSel indices) nr path lbl_path lin lins = do
index <- member indices
restrictHead lbl_path index
restrictArg nr path index
return lins
convertArg StrSel nr cat path lbl_path lin lins = do
convertArg StrSel nr path lbl_path lin lins = do
projectHead lbl_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
args <- mapM evalTerm args
let term = con :^ args
guard (term `elem` terms)
restrictHead lbl_path term
convertCon (ConSel indices) index lbl_path lin lins = do
guard (index `elem` indices)
restrictHead lbl_path index
return lins
convertRec selector [] lbl_path lin lins = return lins
convertRec selector@(RecSel fields) ((label, val):record) lbl_path lin lins = select fields
convertRec cnc_defs selector index [] lbl_path lin lins = return lins
convertRec cnc_defs selector@(TupleSel fields) index (val:record) lbl_path lin lins = select fields
where
select [] = convertRec selector record lbl_path lin lins
select ((label',sub_sel) : fields)
| label == label' = do lins <- convertTerm sub_sel val (Lin (lbl_path ++. label) lin : lins)
convertRec selector record lbl_path lin lins
select [] = convertRec cnc_defs selector (index+1) record lbl_path lin lins
select ((index',sub_sel) : fields)
| index == index' = do lins <- convertTerm cnc_defs sub_sel val ((index:lbl_path,lin) : lins)
convertRec cnc_defs selector (index+1) record lbl_path lin lins
| otherwise = select fields
convertRec (RecPrj label sub_sel) record lbl_path lin lins = do
(label',val) <- member record
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)
convertRec cnc_defs (TuplePrj index' sub_sel) index record lbl_path lin lins = do
convertTerm cnc_defs sub_sel (record !! (fromIntegral (index'-index))) ((lbl_path,lin) : lins)
------------------------------------------------------------
-- eval a term to ground terms
evalTerm :: STerm -> CnvMonad STerm
evalTerm arg@(Arg nr _ path) = do ctype <- readArgCType nr
unifyPType arg $ lintypeFollowPath path ctype
evalTerm (con :^ terms) = do terms <- mapM evalTerm terms
return (con :^ terms)
evalTerm (Rec record) = do record <- mapM evalAssign record
return (Rec record)
evalTerm (term :. lbl) = do term <- evalTerm term
evalTerm (term +. lbl)
evalTerm (Tbl table) = do table <- mapM evalCase table
return (Tbl table)
evalTerm (term :! sel) = do sel <- evalTerm sel
evalTerm (term +! sel)
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
evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex
evalTerm cnc_defs path (V nr) = do term <- readArgCType nr
unifyPType nr (reverse path) (selectTerm path term)
evalTerm cnc_defs path (C nr) = return nr
evalTerm cnc_defs path (R record) = case path of
(index:path) -> evalTerm cnc_defs path (record !! (fromIntegral index))
evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel
evalTerm cnc_defs (index:path) term
evalTerm cnc_defs path (FV terms) = member terms >>= evalTerm cnc_defs path
evalTerm cnc_defs path (RP alias _) = evalTerm cnc_defs path alias
evalTerm cnc_defs path (F id) = do term <- Map.lookup id cnc_defs
evalTerm cnc_defs path term
evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
evalAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
evalAssign (lbl, term) = liftM ((,) lbl) $ evalTerm term
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) =
unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex
unifyPType nr path (C max_index) =
do (_, args, _, _) <- readState
let (FCat _ _ _ tcs,_) = args !! nr
let (FCat _ _ _ tcs,_) = args !! (fromIntegral nr)
case lookup path tcs of
Just term -> return term
Nothing -> do term <- member terms
restrictArg nr path term
return term
Just index -> return index
Nothing -> do index <- member [0..max_index-1]
restrictArg nr path index
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
data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule]
type SRulesMap = Map.Map SCat [SRule]
type FCatSet = Map.Map SCat (Map.Map [SPath] (Map.Map [(SPath,STerm)] (Either FCat FCat)))
type XRulesMap = Map.Map CId [XRule]
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))) []
@@ -266,7 +247,7 @@ genFCatHead env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =
tmap_s = Map.singleton tcs x_fcat
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) =
case Map.lookup cat fcatSet >>= Map.lookup rcs 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)
= foldBM (\tcs st (x_fcat,last_id,tmap,rules) ->
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]])
in if st
then (Right fcat,last_id1,tmap1,rule:rules)
else (x_fcat, last_id, tmap, rules))
(Left fcat,next_id,Map.insert tcs x_fcat tmap,rules)
(gen_tcs ctype emptyPath [])
(gen_tcs ctype [] [])
False
rmap1 = Map.singleton rcs tmap1
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
in (next_id, Map.insert tcs (Left fcat) tmap, fcat)
gen_tcs :: SLinType -> SPath -> [(SPath,STerm)] -> BacktrackM Bool [(SPath,STerm)]
gen_tcs (RecT record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (path ++. label) acc) acc record
gen_tcs (TblT terms ctype) path acc = foldM (\acc term -> gen_tcs ctype (path ++! term ) acc) acc terms
gen_tcs (StrT) path acc = return acc
gen_tcs (ConT terms) path acc =
gen_tcs :: Term -> FPath -> [(FPath,FIndex)] -> BacktrackM Bool [(FPath,FIndex)]
gen_tcs (R record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (label:path) acc) acc (zip [0..] record)
gen_tcs (S _) path acc = return acc
gen_tcs (RP alias _) path acc = gen_tcs alias path acc
gen_tcs (C max_index) path acc =
case List.lookup path tcs of
Just term -> return $! addConstraint path term acc
Nothing -> do writeState True
term <- member terms
return $! addConstraint path term acc
Just index -> return $! addConstraint path index acc
Nothing -> do writeState True
index <- member [0..max_index-1]
return $! addConstraint path index acc
where
addConstraint path0 term0 (c@(path,term) : cs)
| path0 > path = c:addConstraint path0 term0 cs
addConstraint path0 term0 cs = (path0,term0) : cs
addConstraint path0 index0 (c@(path,index) : cs)
| path0 > path = c:addConstraint path0 index0 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)
where
(todo,fcatSet') =
@@ -343,97 +324,82 @@ getFRules (FRulesEnv last_id fcatSet rules) = rules
------------------------------------------------------------
-- The STermSelector
-- The TermSelector
data STermSelector
= RecSel [(Label, STermSelector)]
| TblSel [(STerm, STermSelector)]
| RecPrj Label STermSelector
| TblPrj STerm STermSelector
| ConSel [STerm]
data TermSelector
= TupleSel [(FIndex, TermSelector)]
| TuplePrj FIndex TermSelector
| ConSel [FIndex]
| StrSel
deriving Show
mkSingletonSelectors :: SLinType -> [STermSelector]
mkSingletonSelectors ctype = sels0
mkSingletonSelectors :: Term -- ^ Type representation term
-> [TermSelector] -- ^ list of selectors containing just one string field
mkSingletonSelectors term = sels0
where
(sels0,tcss0) = loop emptyPath ([],[]) ctype
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)
(sels0,tcss0) = loop [] ([],[]) term
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 =
List.foldl' addRestriction (case xs of
(path:xs) -> List.foldl' addProjection (path2selector StrSel path) xs) ys
where
xs = [ reverse path | Path path <- rcs]
ys = [(reverse path,term) | tcs <- tcss, (Path path,term) <- tcs]
xs = [ reverse path | path <- rcs]
ys = [(reverse path,term) | tcs <- tcss, (path,term) <- tcs]
addProjection :: STermSelector -> [Either Label STerm] -> STermSelector
addProjection StrSel [] = StrSel
addProjection (RecSel fields) (Left lbl : path) = RecSel (add fields)
addRestriction :: TermSelector -> (FPath,FIndex) -> TermSelector
addRestriction (ConSel indices) ([] ,n_index) = ConSel (add indices)
where
add [] = [(lbl,path2selector StrSel path)]
add (field@(lbl',sub_sel):fields)
| lbl == lbl' = (lbl',addProjection sub_sel path):fields
add [] = [n_index]
add (index':indices)
| 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
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
addRestriction (ConSel terms) ([] ,term) = ConSel (add terms)
addProjection :: TermSelector -> FPath -> TermSelector
addProjection StrSel [] = StrSel
addProjection (TupleSel fields) (index : path) = TupleSel (add fields)
where
add [] = [term]
add (term':terms)
| term == term' = term': terms
| 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
add [] = [(index,path2selector StrSel path)]
add (field@(index',sub_sel):fields)
| index == index' = (index',addProjection sub_sel path):fields
| otherwise = field : add fields
addRestriction (TblSel cases) (Right pat : path,term) = TblSel (add cases)
where
add [] = [(pat,path2selector (ConSel [term]) 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)]
path2selector base [] = base
path2selector base (index : path) = TupleSel [(index,path2selector base path)]
------------------------------------------------------------
-- updating the MCF rule
readArgCType :: Int -> CnvMonad SLinType
readArgCType arg = do (_, _, _, ctypes) <- readState
return (ctypes !! arg)
readArgCType :: FIndex -> CnvMonad Term
readArgCType nr = do (_, _, _, ctypes) <- readState
return (ctypes !! fromIntegral nr)
restrictArg :: Int -> SPath -> STerm -> CnvMonad ()
restrictArg nr path term = do
restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad ()
restrictArg nr path index = do
(head, args, ctype, ctypes) <- readState
args' <- updateNthM (\(fcat,xs) -> do fcat <- restrictFCat path term fcat
return (fcat,xs) ) nr args
args' <- updateNthM (\(fcat,xs) -> do fcat <- restrictFCat path index fcat
return (fcat,xs) ) (fromIntegral nr) args
writeState (head, args', ctype, ctypes)
projectArg :: Int -> SPath -> CnvMonad Int
projectArg :: FIndex -> FPath -> CnvMonad Int
projectArg nr path = do
(head, args, ctype, ctypes) <- readState
(xnr,args') <- updateArgs nr args
writeState (head, args', ctype, ctypes)
return xnr
where
updateArgs :: Int -> [(FCat,[SPath])] -> CnvMonad (Int,[(FCat,[SPath])])
updateArgs :: FIndex -> [(FCat,[FPath])] -> CnvMonad (Int,[(FCat,[FPath])])
updateArgs 0 ((a@(FCat _ _ rcs _),xpaths) : as)
| path `elem` rcs = return (length xpaths+1,(a,path:xpaths):as)
| otherwise = do a <- projectFCat path a
@@ -442,34 +408,34 @@ projectArg nr path = do
(xnr,as) <- updateArgs (n-1) as
return (xnr,a:as)
readHeadCType :: CnvMonad SLinType
readHeadCType :: CnvMonad Term
readHeadCType = do (_, _, ctype, _) <- readState
return ctype
restrictHead :: SPath -> STerm -> CnvMonad ()
restrictHead :: FPath -> FIndex -> CnvMonad ()
restrictHead path term
= do (head, args, ctype, ctypes) <- readState
head' <- restrictFCat path term head
writeState (head', args, ctype, ctypes)
projectHead :: SPath -> CnvMonad ()
projectHead :: FPath -> CnvMonad ()
projectHead path
= do (head, args, ctype, ctypes) <- readState
head' <- projectFCat path head
writeState (head', args, ctype, ctypes)
restrictFCat :: SPath -> STerm -> FCat -> CnvMonad FCat
restrictFCat path0 term0 (FCat id cat rcs tcs) = do
restrictFCat :: FPath -> FIndex -> FCat -> CnvMonad FCat
restrictFCat path0 index0 (FCat id cat rcs tcs) = do
tcs <- addConstraint tcs
return (FCat id cat rcs tcs)
where
addConstraint (c@(path,term) : cs)
addConstraint (c@(path,index) : cs)
| path0 > path = liftM (c:) (addConstraint cs)
| path0 == path = guard (term0 == term) >>
| path0 == path = guard (index0 == index) >>
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
return (FCat id cat (addConstraint rcs) tcs)
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.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.Values as Values (cString, cInt, cFloat)
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
@@ -110,19 +110,22 @@ mcat2scat = ecat2scat . mcat2ecat
----------------------------------------------------------------------
-- * fast nonerasing MCFG
type FGrammar = FCFGrammar FCat Name Token
type FRule = FCFRule FCat Name Token
data FCat = FCat {-# UNPACK #-} !Int SCat [SPath] [(SPath,STerm)]
type FIndex = Int
type FPath = [FIndex]
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 [] []
fcatString = FCat (-1) Values.cString [Path [Left (AbsGFC.L (Ident.IC "s"))]] []
fcatInt = FCat (-2) Values.cInt [Path [Left (AbsGFC.L (Ident.IC "s"))]] []
fcatFloat = FCat (-3) Values.cFloat [Path [Left (AbsGFC.L (Ident.IC "s"))]] []
fcatString = FCat (-1) (AbsGFCC.CId "String") [[0]] []
fcatInt = FCat (-2) (AbsGFCC.CId "Int") [[0]] []
fcatFloat = FCat (-3) (AbsGFCC.CId "Float") [[0]] []
fcat2scat :: FCat -> SCat
fcat2scat (FCat _ c _ _) = c
fcat2cid :: FCat -> AbsGFCC.CId
fcat2cid (FCat _ c _ _) = c
instance Eq FCat where
(FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2
@@ -130,6 +133,9 @@ instance Eq FCat where
instance Ord FCat where
compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2
instance Print AbsGFCC.CId where
prt (AbsGFCC.CId s) = s
----------------------------------------------------------------------
-- * CFG
@@ -158,8 +164,8 @@ instance Print CCat where
prt (CCat cat label) = prt cat ++ prt label
instance Print FCat where
prt (FCat _ cat rcs tcs) = prt cat ++ "{" ++
prtSep ";" ([prt path | path <- rcs] ++
[prt path ++ "=" ++ prt term | (path,term) <- tcs])
++ "}"
prt (FCat _ (AbsGFCC.CId cat) rcs tcs) = cat ++ "{" ++
prtSep ";" ([prt path | path <- rcs] ++
[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
printFGrammar :: FCFGrammar FCat Name Token -> String
printFGrammar = printTree . fgrammar
printFGrammar :: FCFGrammar FCat FName Token -> String
printFGrammar = undefined {- printTree . fgrammar
fgrammar :: FCFGrammar FCat Name Token -> F.FGrammar
fgrammar = F.FGr . map frule
@@ -98,3 +98,4 @@ ident :: Ident -> F.Ident
ident = F.Ident . prIdent --- is information lost?
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
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
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)
where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\""
mkEsc '\\' = "\\\\"
@@ -47,5 +47,6 @@ instance (Print c, Print t) => Print (FSymbol c t) where
prtList = prtSep " "
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"

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

@@ -23,12 +23,12 @@ import GF.Infra.Print
----------------------------------------------------------------------
-- 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
| otherwise = Bad $ "FCFG parsing strategy not defined: " ++ prs
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' "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.Infra.Ident
import GF.Infra.Print
import GF.Parsing.FCFG.Range
import GF.Parsing.FCFG.PInfo
@@ -34,7 +35,7 @@ import Data.Array
----------------------------------------------------------------------
-- * 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
where chart = process strategy pinfo toks axioms emptyXChart
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 pinfo = SNode ruleid (replicate (length rhs) [])
where
FRule (Abs _ rhs _) _ = allRules pinfo ! ruleid
FRule _ rhs _ _ = allRules pinfo ! ruleid
updateChildren :: SyntaxNode RuleId RangeRec -> Int -> RangeRec -> [SyntaxNode RuleId RangeRec]
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 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 ((c,item):items) chart = process strategy pinfo toks items $! univRule c item chart
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
else univRule cat (Final (reverse (rng:found)) node) chart
where
(FRule (Abs cat _ fn) lins) = allRules pinfo ! ruleid
lin = lins ! lbl
(FRule fn _ cat lins) = allRules pinfo ! ruleid
lin = lins ! lbl
univRule cat item@(Final found' node) chart =
case insertXChart chart item cat of
Nothing -> chart
Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat
let FRule _ lins = allRules pinfo ! ruleid
FSymCat cat r d = lins ! l ! ppos
let FRule _ _ _ lins = allRules pinfo ! ruleid
FSymCat cat r d = lins ! l ! ppos
rng <- concatRange rng (found' !! r)
node <- updateChildren node d found'
return (cat, Active found rng l (ppos+1) node)
++
do guard (isBU strategy)
ruleid <- leftcornerCats pinfo ? cat
let FRule _ lins = allRules pinfo ! ruleid
FSymCat cat r d = lins ! 0 ! 0
let FRule _ _ _ lins = allRules pinfo ! ruleid
FSymCat cat r d = lins ! 0 ! 0
node <- updateChildren (emptyChildren ruleid pinfo) d found'
return (cat, Active [] (found' !! r) 0 1 node)
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 =
accumAssoc groupSyntaxNodes $
[ 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))
SString s -> ((cat,found), SString s)
SInt n -> ((cat,found), SInt n)
@@ -171,5 +172,5 @@ initialBU pinfo toks =
do tok <- aElems (inputToken toks)
ruleid <- leftcornerTokens pinfo ? tok ++
epsilonRules pinfo
let FRule (Abs cat _ _) _ = allRules pinfo ! ruleid
let FRule _ _ cat _ = allRules pinfo ! ruleid
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
topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule (Abs cat _ _) _) <- assocs allrules]
-- emptyrules = [ruleid | (ruleid, FRule (Abs _ [] _) _) <- assocs allrules]
epsilonrules = [ ruleid | (ruleid, FRule _ lins) <- assocs allrules,
topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ cat _) <- assocs allrules]
-- emptyrules = [ruleid | (ruleid, FRule _ [] _ _) <- assocs allrules]
epsilonrules = [ ruleid | (ruleid, FRule _ _ _ lins) <- assocs allrules,
not (inRange (bounds (lins ! 0)) 0) ]
leftcorncats = accumAssoc id
[ (fromJust (getLeftCornerCat lins), ruleid) |
(ruleid, FRule _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ]
(ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ]
leftcorntoks = accumAssoc id
[ (fromJust (getLeftCornerTok lins), ruleid) |
(ruleid, FRule _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ]
(ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ]
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

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.Macros as Macros
import qualified GF.Canon.AbsGFC as AbsGFC
import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC
import qualified GF.Infra.Ident as Ident
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 FCFPInfo = PF.FCFPInfo FCat Name Token
type FCFPInfo = PF.FCFPInfo FCat FName Token
type CFPInfo = PC.CFPInfo CCat Name Token
buildPInfo :: MGrammar -> FGrammar -> CGrammar -> PInfo
@@ -128,17 +129,33 @@ selectParser "m" strategy pinfo startCat inTokens
-- parsing via FCFG
selectParser "f" strategy pinfo startCat inTokens
= 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
fcfParser <- PF.parseFCF strategy
let chart = fcfParser fcfpi startCats inTokens
(i,j) = inputBounds inTokens
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:
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

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

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