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

FCat is just a plain integer now

Browse Source
This commit is contained in:
kr.angelov
2007-10-12 16:00:37 +00:00
parent 96ed0bf4ac
commit 873a160537
6 changed files with 125 additions and 126 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -162,9 +162,9 @@ emptyStateGrammar = StGr {
grammar = M.emptyMGrammar, grammar = M.emptyMGrammar,
cf = emptyCF, cf = emptyCF,
mcfg = [], mcfg = [],
fcfg = [], fcfg = ([], Map.empty),
cfg = [], cfg = [],
pInfo = Prs.buildPInfo [] [] [], pInfo = Prs.buildPInfo [] ([], Map.empty) [],
morpho = emptyMorpho, morpho = emptyMorpho,
probs = emptyProbs, probs = emptyProbs,
loptions = noOptions loptions = noOptions
@@ -401,9 +401,9 @@ stateGrammarOfLangOpt purg st0 l = StGr {
grammar = allCan, grammar = allCan,
cf = maybe emptyCF id (lookup l (cfs st)), cf = maybe emptyCF id (lookup l (cfs st)),
mcfg = maybe [] id $ lookup l $ mcfgs st, mcfg = maybe [] id $ lookup l $ mcfgs st,
fcfg = maybe [] id $ lookup l $ fcfgs st, fcfg = maybe ([],Map.empty) id $ lookup l $ fcfgs st,
cfg = maybe [] id $ lookup l $ cfgs st, cfg = maybe [] id $ lookup l $ cfgs st,
pInfo = maybe (Prs.buildPInfo [] [] []) id $ lookup l $ pInfos st, pInfo = maybe (Prs.buildPInfo [] ([],Map.empty) []) id $ lookup l $ pInfos st,
morpho = maybe emptyMorpho id (lookup l (morphos st)), morpho = maybe emptyMorpho id (lookup l (morphos st)),
probs = maybe emptyProbs id (lookup l (probss st)), probs = maybe emptyProbs id (lookup l (probss st)),
loptions = errVal noOptions $ lookupOptionsCan allCan loptions = errVal noOptions $ lookupOptionsCan allCan
@@ -444,9 +444,9 @@ stateAbstractGrammar st = StGr {
grammar = canModules st, ---- only abstarct ones grammar = canModules st, ---- only abstarct ones
cf = emptyCF, cf = emptyCF,
mcfg = [], mcfg = [],
fcfg = [], fcfg = ([],Map.empty),
cfg = [], cfg = [],
pInfo = Prs.buildPInfo [] [] [], pInfo = Prs.buildPInfo [] ([],Map.empty) [],
morpho = emptyMorpho, morpho = emptyMorpho,
probs = emptyProbs, probs = emptyProbs,
loptions = gloptions st ---- loptions = gloptions st ----

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

@@ -13,7 +13,7 @@
module GF.Conversion.SimpleToFCFG module GF.Conversion.SimpleToFCFG
(convertGrammar,FCat(..)) where (convertGrammar) where
import GF.Infra.PrintClass import GF.Infra.PrintClass
@@ -40,17 +40,18 @@ import Data.Maybe
-- main conversion function -- main conversion function
convertGrammar :: GFCC -> [(CId,FGrammar)] convertGrammar :: GFCC -> [(CId,FGrammar)]
convertGrammar gfcc = [(cncname,convert abs_defs conc cats) | convertGrammar gfcc =
cncname <- cncnames gfcc, [(cncname,convert abs_defs conc cats)
cnc <- Map.lookup cncname (concretes gfcc), | cncname <- cncnames gfcc,
let conc = Map.union (opers cnc) (lins cnc), -- "union big+small most efficient" cnc <- Map.lookup cncname (concretes gfcc),
let cats = lincats cnc] let conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
cats = lincats cnc
]
where where
abs_defs = Map.assocs (funs (abstract gfcc)) abs_defs = Map.assocs (funs (abstract gfcc))
convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar
convert abs_defs cnc_defs cat_defs = getFRules (loop frulesEnv) convert abs_defs cnc_defs cat_defs = getFGrammar (loop frulesEnv)
where where
srules = [ srules = [
(XRule id args res (map findLinType args) (findLinType res) term) | (XRule id args res (map findLinType args) (findLinType res) term) |
@@ -59,17 +60,17 @@ convertGrammar gfcc = [(cncname,convert abs_defs conc cats) |
findLinType id = fromJust (Map.lookup id cat_defs) findLinType id = fromJust (Map.lookup id cat_defs)
(srulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules (xrulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules
where where
helper (srulesMap,frulesEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) = helper (xrulesMap,frulesEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) =
let srulesMap' = Map.insertWith (++) abs_res [rule] srulesMap let xrulesMap' = Map.insertWith (++) abs_res [rule] xrulesMap
frulesEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env) frulesEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env)
frulesEnv frulesEnv
(mkSingletonSelectors cnc_defs cnc_res) (mkSingletonSelectors cnc_defs cnc_res)
in srulesMap' `seq` frulesEnv' `seq` (srulesMap',frulesEnv') in xrulesMap' `seq` frulesEnv' `seq` (xrulesMap',frulesEnv')
loop frulesEnv = loop frulesEnv =
let (todo, frulesEnv') = takeToDoRules srulesMap frulesEnv let (todo, frulesEnv') = takeToDoRules xrulesMap frulesEnv
in case todo of in case todo of
[] -> frulesEnv' [] -> frulesEnv'
_ -> loop $! List.foldl' (\env (srules,selector) -> _ -> loop $! List.foldl' (\env (srules,selector) ->
@@ -80,27 +81,27 @@ convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) frulesEnv =
foldBM addRule foldBM addRule
frulesEnv frulesEnv
(convertTerm cnc_defs selector term [([],[])]) (convertTerm cnc_defs selector term [([],[])])
(initialFCat cat, map (\scat -> (initialFCat scat,[])) args, ctype, ctypes) (protoFCat cat, map (\scat -> (protoFCat 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'
(env2, newArgs,idxArgs) = foldr (\((fcat@(FCat _ cat rcs tcs),xpaths),ctype,idx) (env,args,all_args) -> (env2, newArgs,idxArgs) = foldr (\((xcat@(PFCat cat rcs tcs),xpaths),ctype,idx) (env,args,all_args) ->
let xargs = fcat:[FCat 0 cat [path] tcs | path <- reverse xpaths] let xargs = xcat:[PFCat cat [path] tcs | path <- reverse xpaths]
(env1, xargs1) = List.mapAccumL (genFCatArg cnc_defs ctype) env xargs (env1, xargs1) = List.mapAccumL (genFCatArg cnc_defs ctype) env xargs
in case fcat of in case xcat of
FCat _ _ [] _ -> (env , args, all_args) PFCat _ [] _ -> (env , args, all_args)
_ -> (env1,xargs1++args,(idx,xargs1):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..]) _ -> (env1,xargs1++args,(idx,zip xargs1 xargs):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 {PFCat _ rcs _ -> rcs}]
(_,newProfile) = List.mapAccumL accumProf 0 newArgs' (_,newProfile) = List.mapAccumL accumProf 0 newArgs'
where where
accumProf nr (FCat _ _ [] _,_ ) = (nr, Unify [] ) accumProf nr (PFCat _ [] _,_ ) = (nr, Unify [] )
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 (Name fun newProfile) newArgs newCat newLinRec rule = FRule (Name fun newProfile) newArgs newCat newLinRec
in addFCatRule env2 rule in addFRule env2 rule
translateLin idxArgs lbl' [] = array (0,-1) [] translateLin idxArgs lbl' [] = array (0,-1) []
translateLin idxArgs lbl' ((lbl,syms) : lins) translateLin idxArgs lbl' ((lbl,syms) : lins)
@@ -109,8 +110,8 @@ translateLin idxArgs lbl' ((lbl,syms) : 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 (fcat, PFCat _ rcs _) = xargs !! xnr
in FSymCat arg (index lbl rcs 0) (nr'+xnr) in FSymCat fcat (index lbl rcs 0) (nr'+xnr)
| otherwise = instCat lbl nr xnr (nr'+length xargs) idxArgs | otherwise = instCat lbl nr xnr (nr'+length xargs) idxArgs
index lbl' (lbl:lbls) idx index lbl' (lbl:lbls) idx
@@ -123,7 +124,7 @@ translateLin idxArgs lbl' ((lbl,syms) : lins)
type CnvMonad a = BacktrackM Env a type CnvMonad a = BacktrackM Env a
type Env = (FCat, [(FCat,[FPath])], Term, [Term]) type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term])
type LinRec = [(FPath, [Symbol (FPath, FIndex, Int) FToken])] type LinRec = [(FPath, [Symbol (FPath, FIndex, Int) FToken])]
type TermMap = Map.Map CId Term type TermMap = Map.Map CId Term
@@ -211,7 +212,7 @@ evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex
unifyPType nr path (C max_index) = unifyPType nr path (C max_index) =
do (_, args, _, _) <- readState do (_, args, _, _) <- readState
let (FCat _ _ _ tcs,_) = args !! nr let (PFCat _ _ tcs,_) = args !! nr
case lookup path tcs of case lookup path tcs of
Just index -> return index Just index -> return index
Nothing -> do index <- member [0..max_index] Nothing -> do index <- member [0..max_index]
@@ -231,43 +232,50 @@ selectTerm path (RP _ term) = selectTerm path term
-- FRulesEnv -- FRulesEnv
data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule] data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule]
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))) type FCatSet = Map.Map CId (Map.Map [FPath] (Map.Map [(FPath,FIndex)] (Either FCat FCat)))
data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)]
emptyFRulesEnv = FRulesEnv 0 (ins fcatString (ins fcatInt (ins fcatFloat Map.empty))) [] protoFCat :: CId -> ProtoFCat
protoFCat cat = PFCat cat [] []
emptyFRulesEnv = FRulesEnv 0 (ins fcatString (CId "String") [[0]] [] $
ins fcatInt (CId "Int") [[0]] [] $
ins fcatFloat (CId "Float") [[0]] [] $
Map.empty) []
where where
ins fcat@(FCat _ cat rcs tcs) fcatSet = ins fcat cat rcs tcs fcatSet =
Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs x_fcat) rcs tmap_s) cat rmap_s fcatSet Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s fcatSet
where where
x_fcat = Right fcat right_fcat = Right fcat
tmap_s = Map.singleton tcs x_fcat tmap_s = Map.singleton tcs right_fcat
rmap_s = Map.singleton rcs tmap_s rmap_s = Map.singleton rcs tmap_s
genFCatHead :: FRulesEnv -> FCat -> (FRulesEnv, FCat) addFRule :: FRulesEnv -> FRule -> FRulesEnv
genFCatHead env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) = addFRule (FRulesEnv last_id fcatSet rules) rule = FRulesEnv last_id fcatSet (rule:rules)
getFGrammar :: FRulesEnv -> FGrammar
getFGrammar (FRulesEnv last_id fcatSet rules) = (rules, Map.map getFCatList fcatSet)
where
getFCatList rcs = Map.fold (\tcs lst -> Map.fold (\x lst -> either id id x : lst) lst tcs) [] rcs
genFCatHead :: FRulesEnv -> ProtoFCat -> (FRulesEnv, FCat)
genFCatHead env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs tcs) =
case Map.lookup cat fcatSet >>= Map.lookup rcs >>= Map.lookup tcs of case Map.lookup cat fcatSet >>= Map.lookup rcs >>= Map.lookup tcs of
Just (Left fcat) -> (FRulesEnv last_id (ins fcat) rules, fcat) Just (Left fcat) -> (FRulesEnv last_id (ins fcat) rules, fcat)
Just (Right fcat) -> (env, fcat) Just (Right fcat) -> (env, fcat)
Nothing -> let next_id = last_id+1 Nothing -> let fcat = last_id+1
fcat = FCat next_id cat rcs tcs in (FRulesEnv fcat (ins fcat) rules, fcat)
in (FRulesEnv next_id (ins fcat) rules, fcat)
where where
ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs x_fcat) rcs tmap_s) cat rmap_s fcatSet ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s fcatSet
where where
x_fcat = Right fcat right_fcat = Right fcat
tmap_s = Map.singleton tcs x_fcat tmap_s = Map.singleton tcs right_fcat
rmap_s = Map.singleton rcs tmap_s rmap_s = Map.singleton rcs tmap_s
genFCatArg :: TermMap -> Term -> FRulesEnv -> FCat -> (FRulesEnv, FCat) genFCatArg :: TermMap -> Term -> FRulesEnv -> ProtoFCat -> (FRulesEnv, FCat)
genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) = genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat 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
Just (Left fcat) -> (env, fcat) Just (Left fcat) -> (env, fcat)
@@ -276,17 +284,16 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat r
Nothing -> ins Map.empty Nothing -> ins Map.empty
where where
ins tmap = ins tmap =
let next_id = last_id+1 let fcat = last_id+1
fcat = FCat next_id cat rcs tcs (either_fcat,last_id1,tmap1,rules1)
(x_fcat,last_id1,tmap1,rules1) = foldBM (\tcs st (either_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 (Name (CId "_") [Unify [0]]) [fcat_arg] fcat 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 (either_fcat,last_id, tmap, rules))
(Left fcat,next_id,Map.insert tcs x_fcat tmap,rules) (Left fcat,fcat,Map.insert tcs either_fcat tmap,rules)
(gen_tcs ctype [] []) (gen_tcs ctype [] [])
False False
rmap1 = Map.singleton rcs tmap1 rmap1 = Map.singleton rcs tmap1
@@ -296,9 +303,8 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat r
case Map.lookup tcs tmap of case Map.lookup tcs tmap of
Just (Left fcat) -> (last_id, tmap, fcat) Just (Left fcat) -> (last_id, tmap, fcat)
Just (Right fcat) -> (last_id, tmap, fcat) Just (Right fcat) -> (last_id, tmap, fcat)
Nothing -> let next_id = last_id+1 Nothing -> let fcat = last_id+1
fcat = FCat next_id cat rcs tcs in (fcat, Map.insert tcs (Left fcat) tmap, fcat)
in (next_id, Map.insert tcs (Left fcat) tmap, fcat)
gen_tcs :: Term -> FPath -> [(FPath,FIndex)] -> BacktrackM Bool [(FPath,FIndex)] 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 (R record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (label:path) acc) acc (zip [0..] record)
@@ -319,32 +325,38 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat r
Nothing -> error ("unknown identifier: "++prt id) Nothing -> error ("unknown identifier: "++prt id)
------------------------------------------------------------
-- TODO queue organization
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 -}
takeToDoRules :: XRulesMap -> FRulesEnv -> ([([XRule], TermSelector)], FRulesEnv) takeToDoRules :: XRulesMap -> FRulesEnv -> ([([XRule], TermSelector)], FRulesEnv)
takeToDoRules srulesMap (FRulesEnv last_id fcatSet rules) = (todo,FRulesEnv last_id fcatSet' rules) takeToDoRules xrulesMap (FRulesEnv last_id fcatSet rules) = (todo,FRulesEnv last_id fcatSet' rules)
where where
(todo,fcatSet') = (todo,fcatSet') =
Map.mapAccumWithKey (\todo cat rmap -> Map.mapAccumWithKey (\todo cat rmap ->
let (todo1,rmap1) = Map.mapAccumWithKey (\todo rcs tmap -> let (todo1,rmap1) = Map.mapAccumWithKey (\todo rcs tmap ->
let (tcss,tmap') = Map.mapAccumWithKey (\tcss tcs x_fcat -> let (tcss,tmap') = Map.mapAccumWithKey (\tcss tcs either_xcat ->
case x_fcat of case either_xcat of
Left fcat -> (tcs:tcss,Right fcat) Left xcat -> (tcs:tcss,Right xcat)
Right fcat -> ( tcss, x_fcat)) [] tmap Right xcat -> ( tcss,either_xcat)) [] tmap
in case tcss of in case tcss of
[] -> ( todo,tmap ) [] -> ( todo,tmap )
_ -> ((srules,mkSelector rcs tcss) : todo,tmap')) todo rmap _ -> ((srules,mkSelector rcs tcss) : todo,tmap')) todo rmap
mb_srules = Map.lookup cat srulesMap mb_srules = Map.lookup cat xrulesMap
Just srules = mb_srules Just srules = mb_srules
in case mb_srules of in case mb_srules of
Just srules -> (todo1,rmap1) Just srules -> (todo1,rmap1)
Nothing -> (todo ,rmap1)) [] fcatSet Nothing -> (todo ,rmap1)) [] fcatSet
addFCatRule :: FRulesEnv -> FRule -> FRulesEnv
addFCatRule (FRulesEnv last_id fcatSet rules) rule = FRulesEnv last_id fcatSet (rule:rules)
getFRules :: FRulesEnv -> [FRule]
getFRules (FRulesEnv last_id fcatSet rules) = rules
------------------------------------------------------------ ------------------------------------------------------------
-- The TermSelector -- The TermSelector
@@ -415,8 +427,8 @@ readArgCType nr = do (_, _, _, ctypes) <- readState
restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad () restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad ()
restrictArg nr path index = do restrictArg nr path index = do
(head, args, ctype, ctypes) <- readState (head, args, ctype, ctypes) <- readState
args' <- updateNthM (\(fcat,xs) -> do fcat <- restrictFCat path index fcat args' <- updateNthM (\(xcat,xs) -> do xcat <- restrictProtoFCat path index xcat
return (fcat,xs) ) nr args return (xcat,xs) ) nr args
writeState (head, args', ctype, ctypes) writeState (head, args', ctype, ctypes)
projectArg :: FIndex -> FPath -> CnvMonad Int projectArg :: FIndex -> FPath -> CnvMonad Int
@@ -426,10 +438,10 @@ projectArg nr path = do
writeState (head, args', ctype, ctypes) writeState (head, args', ctype, ctypes)
return xnr return xnr
where where
updateArgs :: FIndex -> [(FCat,[FPath])] -> CnvMonad (Int,[(FCat,[FPath])]) updateArgs :: FIndex -> [(ProtoFCat,[FPath])] -> CnvMonad (Int,[(ProtoFCat,[FPath])])
updateArgs 0 ((a@(FCat _ _ rcs _),xpaths) : as) updateArgs 0 ((a@(PFCat _ 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 <- projectProtoFCat path a
return (0,(a,xpaths):as) return (0,(a,xpaths):as)
updateArgs n (a : as) = do updateArgs n (a : as) = do
(xnr,as) <- updateArgs (n-1) as (xnr,as) <- updateArgs (n-1) as
@@ -442,19 +454,19 @@ readHeadCType = do (_, _, ctype, _) <- readState
restrictHead :: FPath -> FIndex -> 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' <- restrictProtoFCat path term head
writeState (head', args, ctype, ctypes) writeState (head', args, ctype, ctypes)
projectHead :: FPath -> 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' <- projectProtoFCat path head
writeState (head', args, ctype, ctypes) writeState (head', args, ctype, ctypes)
restrictFCat :: FPath -> FIndex -> FCat -> CnvMonad FCat restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat
restrictFCat path0 index0 (FCat id cat rcs tcs) = do restrictProtoFCat path0 index0 (PFCat cat rcs tcs) = do
tcs <- addConstraint tcs tcs <- addConstraint tcs
return (FCat id cat rcs tcs) return (PFCat cat rcs tcs)
where where
addConstraint (c@(path,index) : cs) addConstraint (c@(path,index) : cs)
| path0 > path = liftM (c:) (addConstraint cs) | path0 > path = liftM (c:) (addConstraint cs)
@@ -462,9 +474,9 @@ restrictFCat path0 index0 (FCat id cat rcs tcs) = do
return (c : cs) return (c : cs)
addConstraint cs = return ((path0,index0) : cs) addConstraint cs = return ((path0,index0) : cs)
projectFCat :: FPath -> FCat -> CnvMonad FCat projectProtoFCat :: FPath -> ProtoFCat -> CnvMonad ProtoFCat
projectFCat path0 (FCat id cat rcs tcs) = do projectProtoFCat path0 (PFCat cat rcs tcs) = do
return (FCat id cat (addConstraint rcs) tcs) return (PFCat cat (addConstraint rcs) tcs)
where where
addConstraint (path : rcs) addConstraint (path : rcs)
| path0 > path = path : addConstraint rcs | path0 > path = path : addConstraint rcs

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

@@ -14,11 +14,9 @@ module GF.Formalism.FCFG
-- * Category -- * Category
, FPath , FPath
, FCat(..) , FCat
, initialFCat
, fcatString, fcatInt, fcatFloat , fcatString, fcatInt, fcatFloat
, fcat2cid
-- * Symbol -- * Symbol
, FIndex , FIndex
@@ -37,6 +35,7 @@ module GF.Formalism.FCFG
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.List (groupBy) import Data.List (groupBy)
import Data.Array import Data.Array
import qualified Data.Map as Map
import GF.Formalism.Utilities import GF.Formalism.Utilities
import qualified GF.GFCC.AbsGFCC as AbsGFCC import qualified GF.GFCC.AbsGFCC as AbsGFCC
@@ -51,30 +50,18 @@ type FToken = String
------------------------------------------------------------ ------------------------------------------------------------
-- Category -- Category
type FPath = [FIndex] type FPath = [FIndex]
data FCat = FCat {-# UNPACK #-} !Int AbsGFCC.CId [FPath] [(FPath,FIndex)] type FCat = Int
initialFCat :: AbsGFCC.CId -> FCat
initialFCat cat = FCat 0 cat [] []
fcatString = FCat (-1) (AbsGFCC.CId "String") [[0]] []
fcatInt = FCat (-2) (AbsGFCC.CId "Int") [[0]] []
fcatFloat = FCat (-3) (AbsGFCC.CId "Float") [[0]] []
fcat2cid :: FCat -> AbsGFCC.CId
fcat2cid (FCat _ c _ _) = c
instance Eq FCat where
(FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2
instance Ord FCat where
compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2
fcatString, fcatInt, fcatFloat :: Int
fcatString = (-1)
fcatInt = (-2)
fcatFloat = (-3)
------------------------------------------------------------ ------------------------------------------------------------
-- Symbol -- Symbol
type FIndex = Int type FIndex = Int
data FSymbol data FSymbol
= FSymCat FCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int = FSymCat {-# UNPACK #-} !FCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int
| FSymTok FToken | FSymTok FToken
@@ -89,10 +76,10 @@ isCoercionF _ = False
------------------------------------------------------------ ------------------------------------------------------------
-- Grammar -- Grammar
type FGrammar = [FRule]
type FPointPos = Int
data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
type FPointPos = Int
type FGrammar = ([FRule], Map.Map AbsGFCC.CId [FCat])
data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
------------------------------------------------------------ ------------------------------------------------------------
-- pretty-printing -- pretty-printing
@@ -100,12 +87,6 @@ data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol)
instance Print AbsGFCC.CId where instance Print AbsGFCC.CId where
prt (AbsGFCC.CId s) = s prt (AbsGFCC.CId s) = s
instance Print FCat where
prt (FCat _ (AbsGFCC.CId cat) rcs tcs) = cat ++ "{" ++
prtSep ";" ([prt path | path <- rcs] ++
[prt path ++ "=" ++ prt term | (path,term) <- tcs])
++ "}"
instance Print FSymbol where instance Print FSymbol where
prt (FSymCat c l n) = "($" ++ 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)

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

@@ -25,6 +25,7 @@ import GF.GFCC.AbsGFCC
import GF.GFCC.Macros import GF.GFCC.Macros
import GF.GFCC.ErrM import GF.GFCC.ErrM
import qualified Data.Map as Map
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- parsing -- parsing
@@ -39,9 +40,8 @@ parseFCF ::
Err [Exp] -- ^ resulting GF terms Err [Exp] -- ^ resulting GF terms
parseFCF strategy pinfo startCat inString = parseFCF strategy pinfo startCat inString =
do let inTokens = input inString do let inTokens = input inString
startCats = filter isStart $ grammarCats pinfo startCats <- Map.lookup startCat (startupCats pinfo)
isStart cat = fcat2cid cat == startCat fcfParser <- {- trace lctree $ -} parseFCF strategy
fcfParser <- parseFCF strategy
let chart = fcfParser pinfo startCats inTokens let chart = fcfParser pinfo startCats inTokens
(i,j) = inputBounds inTokens (i,j) = inputBounds inTokens
finalEdges = [makeFinalEdge cat i j | cat <- startCats] finalEdges = [makeFinalEdge cat i j | cat <- startCats]

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

@@ -15,9 +15,13 @@ import GF.Formalism.FCFG
import GF.Data.SortedList import GF.Data.SortedList
import GF.Data.Assoc import GF.Data.Assoc
import GF.Parsing.FCFG.Range import GF.Parsing.FCFG.Range
import qualified GF.GFCC.AbsGFCC as AbsGFCC
import Data.Array import Data.Array
import Data.Maybe import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Debug.Trace
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- type declarations -- type declarations
@@ -48,6 +52,7 @@ data FCFPInfo
-- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury):
, grammarCats :: SList FCat , grammarCats :: SList FCat
, grammarToks :: SList FToken , grammarToks :: SList FToken
, startupCats :: Map.Map AbsGFCC.CId [FCat]
} }
@@ -68,7 +73,7 @@ getLeftCornerCat lins
syms = lins ! 0 syms = lins ! 0
buildFCFPInfo :: FGrammar -> FCFPInfo buildFCFPInfo :: FGrammar -> FCFPInfo
buildFCFPInfo grammar = buildFCFPInfo (grammar,startup) = -- trace (unlines [prt (x,Set.toList set) | (x,set) <- Map.toList leftcornFilter]) $
FCFPInfo { allRules = allrules FCFPInfo { allRules = allrules
, topdownRules = topdownrules , topdownRules = topdownrules
-- , emptyRules = emptyrules -- , emptyRules = emptyrules
@@ -77,6 +82,7 @@ buildFCFPInfo grammar =
, leftcornerTokens = leftcorntoks , leftcornerTokens = leftcorntoks
, grammarCats = grammarcats , grammarCats = grammarcats
, grammarToks = grammartoks , grammarToks = grammartoks
, startupCats = startup
} }
where allrules = listArray (0,length grammar-1) grammar where allrules = listArray (0,length grammar-1) grammar

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

@@ -299,7 +299,7 @@ customGrammarPrinter =
-- grammar conversions: -- grammar conversions:
,(strCI "mcfg", \_ -> Prt.prt . stateMCFG) ,(strCI "mcfg", \_ -> Prt.prt . stateMCFG)
,(strCI "fcfg", \_ -> Prt.prt . stateFCFG) ,(strCI "fcfg", \_ -> Prt.prt . fst . stateFCFG)
,(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)