From 64d3a1226da712bcf3c2744bcc141ebd40acac27 Mon Sep 17 00:00:00 2001 From: krasimir Date: Thu, 29 May 2008 10:55:34 +0000 Subject: [PATCH] simplify the Profile type and remove the NameProfile type --- src-3.0/GF/Compile/GenerateFCFG.hs | 14 +++--- src-3.0/GF/Formalism/FCFG.hs | 34 ++++++--------- src-3.0/GF/Formalism/Utilities.hs | 70 ------------------------------ src-3.0/GF/GFCC/GFCCtoJS.hs | 27 ++++-------- src-3.0/GF/GFCC/Raw/ConvertGFCC.hs | 56 ++++++++---------------- src-3.0/GF/Parsing/FCFG.hs | 32 ++++---------- src-3.0/GF/Parsing/FCFG/Active.hs | 19 ++++---- src-3.0/GF/Parsing/FCFG/PInfo.hs | 17 ++++---- 8 files changed, 74 insertions(+), 195 deletions(-) diff --git a/src-3.0/GF/Compile/GenerateFCFG.hs b/src-3.0/GF/Compile/GenerateFCFG.hs index f68352b6c..89e4d3ef0 100644 --- a/src-3.0/GF/Compile/GenerateFCFG.hs +++ b/src-3.0/GF/Compile/GenerateFCFG.hs @@ -97,9 +97,9 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, -- replaces __NCat with _B and _Var_Cat with _. -- the temporary names are just there to avoid name collisions. fixHoasFuns :: FGrammar -> FGrammar -fixHoasFuns (rs, cs) = ([FRule (fixName n) args cat lins | FRule n args cat lins <- rs], cs) - where fixName (Name (CId n) p) | BS.pack "__" `BS.isPrefixOf` n = Name (mkCId "_B") p - | BS.pack "_Var_" `BS.isPrefixOf` n = Name wildCId p +fixHoasFuns (rs, cs) = ([FRule (fixName n) ps args cat lins | FRule n ps args cat lins <- rs], cs) + where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B") + | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId fixName n = n convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar @@ -148,11 +148,11 @@ convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) frulesEnv = (_,newProfile) = List.mapAccumL accumProf 0 newArgs' where - accumProf nr (PFCat _ [] _,_ ) = (nr, Unify [] ) - accumProf nr (_ ,xpaths) = (nr+cnt+1, Unify [nr..nr+cnt]) + accumProf nr (PFCat _ [] _,_ ) = (nr, [] ) + accumProf nr (_ ,xpaths) = (nr+cnt+1, [nr..nr+cnt]) where cnt = length xpaths - rule = FRule (Name fun newProfile) newArgs newCat newLinRec + rule = FRule fun newProfile newArgs newCat newLinRec in addFRule env2 rule translateLin idxArgs lbl' [] = array (0,-1) [] @@ -336,7 +336,7 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs t (either_fcat,last_id1,tmap1,rules1) = foldBM (\tcs st (either_fcat,last_id,tmap,rules) -> let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap - rule = FRule (Name wildCId [Unify [0]]) [fcat_arg] fcat + rule = FRule wildCId [[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) diff --git a/src-3.0/GF/Formalism/FCFG.hs b/src-3.0/GF/Formalism/FCFG.hs index 2f3994b6c..96e88c8cf 100644 --- a/src-3.0/GF/Formalism/FCFG.hs +++ b/src-3.0/GF/Formalism/FCFG.hs @@ -22,11 +22,8 @@ module GF.Formalism.FCFG , FIndex , FSymbol(..) - -- * Name - , FName - , isCoercionF - -- * Grammar + , Profile , FPointPos , FGrammar , FRule(..) @@ -38,7 +35,7 @@ import Data.Array import qualified Data.Map as Map import GF.Formalism.Utilities -import qualified GF.GFCC.CId as AbsGFCC +import GF.GFCC.CId import GF.Infra.PrintClass ------------------------------------------------------------ @@ -66,27 +63,19 @@ data FSymbol | FSymTok FToken ------------------------------------------------------------- --- Name -type FName = NameProfile AbsGFCC.CId - -isCoercionF :: FName -> Bool -isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.wildCId -isCoercionF _ = False - - ------------------------------------------------------------ -- Grammar +type Profile = [Int] type FPointPos = Int -type FGrammar = ([FRule], Map.Map AbsGFCC.CId [FCat]) -data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol)) +type FGrammar = ([FRule], Map.Map CId [FCat]) +data FRule = FRule CId [Profile] [FCat] FCat (Array FIndex (Array FPointPos FSymbol)) ------------------------------------------------------------ -- pretty-printing -instance Print AbsGFCC.CId where - prt = AbsGFCC.prCId +instance Print CId where + prt = prCId instance Print FSymbol where prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")" @@ -100,6 +89,11 @@ instance Print FSymbol where prtList = prtSep " " instance Print FRule where - 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]++"]" + prt (FRule fun profile args res lins) = + prt fun ++ prtProf profile ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++ + " =\n [" ++ prtSep "\n " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs lins]++"]" + where + prtProf [] = "?" + prtProf args = prtSep "=" args + prtList = prtSep "\n" diff --git a/src-3.0/GF/Formalism/Utilities.hs b/src-3.0/GF/Formalism/Utilities.hs index d1826d095..ea1f1eeca 100644 --- a/src-3.0/GF/Formalism/Utilities.hs +++ b/src-3.0/GF/Formalism/Utilities.hs @@ -309,66 +309,6 @@ forest2trees (FMeta) = [TMeta] ---------------------------------------------------------------------- -- * profiles --- | Pairing a rule name with a profile -data NameProfile a = Name a [Profile (SyntaxForest a)] - deriving (Eq, Ord, Show) - -name2fun :: NameProfile a -> a -name2fun (Name fun _) = fun - --- | A profile is a simple representation of a function on a number of arguments. --- We only use lists of profiles -data Profile a = Unify [Int] -- ^ The Int's are the argument positions. - -- 'Unify []' will become a metavariable, - -- 'Unify [a,b]' means that the arguments are equal, - | Constant a - deriving (Eq, Ord, Show) - -instance Functor Profile where - fmap f (Constant a) = Constant (f a) - fmap f (Unify xs) = Unify xs - --- | a function name where the profile does not contain arguments --- (i.e. denoting a constant, not a function) -constantNameToForest :: NameProfile a -> SyntaxForest a -constantNameToForest name@(Name fun profile) = FNode fun [map unConstant profile] - where unConstant (Constant a) = a - unConstant (Unify []) = FMeta - unConstant _ = error $ "constantNameToForest: the profile should not contain arguments" - --- | profile application; we need some way of unifying a list of arguments -applyProfile :: ([b] -> a) -> [Profile a] -> [b] -> [a] -applyProfile unify profile args = map apply profile - where apply (Unify xs) = unify $ map (args !!) xs - apply (Constant a) = a - --- | monadic profile application -applyProfileM :: Monad m => ([b] -> m a) -> [Profile a] -> [b] -> m [a] -applyProfileM unify profile args = mapM apply profile - where apply (Unify xs) = unify $ map (args !!) xs - apply (Constant a) = return a - --- | profile composition: --- --- > applyProfile u z (ps `composeProfiles` qs) args --- > == --- > applyProfile u z ps (applyProfile u z qs args) --- --- compare with function composition --- --- > (p . q) arg --- > == --- > p (q arg) --- --- Note that composing an 'Constant' with two or more arguments returns an error --- (since 'Unify' can only take arguments) -- this might change in the future, if there is a need. -composeProfiles :: [Profile a] -> [Profile a] -> [Profile a] -composeProfiles ps qs = map compose ps - where compose (Unify [x]) = qs !! x - compose (Unify xs) = Unify [ y | x <- xs, let Unify ys = qs !! x, y <- ys ] - compose constant = constant - - ------------------------------------------------------------ -- pretty-printing @@ -411,13 +351,3 @@ instance (Print s) => Print (SyntaxForest s) where prt (FFloat f) = show f prt (FMeta) = "?" prtList = prtAfter "\n" - -instance Print a => Print (Profile a) where - prt (Unify []) = "?" - prt (Unify args) = prtSep "=" args - prt (Constant a) = prt a - -instance Print a => Print (NameProfile a) where - prt (Name fun profile) = prt fun ++ prt profile - - diff --git a/src-3.0/GF/GFCC/GFCCtoJS.hs b/src-3.0/GF/GFCC/GFCCtoJS.hs index 91dd89b09..abf7e45a9 100644 --- a/src-3.0/GF/GFCC/GFCCtoJS.hs +++ b/src-3.0/GF/GFCC/GFCCtoJS.hs @@ -8,7 +8,6 @@ import qualified GF.JavaScript.PrintJS as JS import GF.Formalism.FCFG import GF.Parsing.FCFG.PInfo -import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..)) import GF.Text.UTF8 import GF.Data.ErrM @@ -97,29 +96,19 @@ parser2js start p = [new "Parser" [JS.EStr start, cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is)) frule2js :: FRule -> JS.Expr -frule2js (FRule n args res lins) = new "Rule" [JS.EInt res, name2js n, JS.EArray (map JS.EInt args), lins2js lins] +frule2js (FRule f ps args res lins) = new "Rule" [JS.EInt res, name2js (f,ps), JS.EArray (map JS.EInt args), lins2js lins] -name2js :: FName -> JS.Expr -name2js n = case n of - Name f [p] | f == wildCId -> fromProfile p - Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)] +name2js :: (CId,[Profile]) -> JS.Expr +name2js (f,ps) | f == wildCId = fromProfile (head ps) + | otherwise = new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)] where - fromProfile :: Profile (SyntaxForest CId) -> JS.Expr - fromProfile (Unify []) = new "MetaVar" [] - fromProfile (Unify [x]) = daughter x - fromProfile (Unify args) = new "Unify" [JS.EArray (map daughter args)] - fromProfile (Constant forest) = fromSyntaxForest forest + fromProfile :: Profile -> JS.Expr + fromProfile [] = new "MetaVar" [] + fromProfile [x] = daughter x + fromProfile args = new "Unify" [JS.EArray (map daughter args)] daughter i = new "Arg" [JS.EInt i] - fromSyntaxForest :: SyntaxForest CId -> JS.Expr - fromSyntaxForest FMeta = new "MetaVar" [] - -- FIXME: is there always just one element here? - fromSyntaxForest (FNode n [args]) = new "FunApp" $ [JS.EStr $ prCId n, JS.EArray (map fromSyntaxForest args)] - fromSyntaxForest (FString s) = new "Lit" $ [JS.EStr s] - fromSyntaxForest (FInt i) = new "Lit" $ [JS.EInt $ fromIntegral i] - fromSyntaxForest (FFloat f) = new "Lit" $ [JS.EDbl f] - lins2js :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls] diff --git a/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs index 7f5e0ba00..324f8be04 100644 --- a/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs +++ b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs @@ -7,7 +7,7 @@ import GF.GFCC.Raw.AbsGFCCRaw import GF.Infra.PrintClass import GF.Data.Assoc import GF.Formalism.FCFG -import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..)) +import GF.Formalism.Utilities import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo) import qualified Data.Array as Array @@ -78,29 +78,21 @@ toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats) toFRule (App "rule" [n, App "cats" (rt:at), - App "R" ls]) = FRule name args res lins + App "R" ls]) = FRule fun prof args res lins where - name = toFName n + (fun,prof) = toFName n args = lmap expToInt at res = expToInt rt lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls] -toFName :: RExp -> FName -toFName (App "_A" [x]) = Name wildCId [Unify [expToInt x]] -toFName (App f ts) = Name (mkCId f) (lmap toProfile ts) +toFName :: RExp -> (CId,[Profile]) +toFName (App "_A" [x]) = (wildCId, [[expToInt x]]) +toFName (App f ts) = (mkCId f, lmap toProfile ts) where - toProfile :: RExp -> Profile (SyntaxForest CId) - toProfile AMet = Unify [] - toProfile (App "_A" [t]) = Unify [expToInt t] - toProfile (App "_U" ts) = Unify [expToInt t | App "_A" [t] <- ts] - toProfile t = Constant (toSyntaxForest t) - - toSyntaxForest :: RExp -> SyntaxForest CId - toSyntaxForest AMet = FMeta - toSyntaxForest (App n ts) = FNode (mkCId n) [lmap toSyntaxForest ts] - toSyntaxForest (AStr s) = FString s - toSyntaxForest (AInt i) = FInt i - toSyntaxForest (AFlt f) = FFloat f + toProfile :: RExp -> Profile + toProfile AMet = [] + toProfile (App "_A" [t]) = [expToInt t] + toProfile (App "_U" ts) = [expToInt t | App "_A" [t] <- ts] toSymbol :: RExp -> FSymbol toSymbol (App "P" [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n) @@ -221,33 +213,23 @@ fromPInfo p = App "parser" [ ] fromFRule :: FRule -> RExp -fromFRule (FRule n args res lins) = - App "rule" [fromFName n, +fromFRule (FRule fun prof args res lins) = + App "rule" [fromFName (fun,prof), App "cats" (intToExp res:lmap intToExp args), App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins] ] -fromFName :: FName -> RExp -fromFName n = case n of - Name f ps | f == wildCId -> fromProfile (head ps) - | otherwise -> App (prCId f) (lmap fromProfile ps) +fromFName :: (CId,[Profile]) -> RExp +fromFName (f,ps) | f == wildCId = fromProfile (head ps) + | otherwise = App (prCId f) (lmap fromProfile ps) where - fromProfile :: Profile (SyntaxForest CId) -> RExp - fromProfile (Unify []) = AMet - fromProfile (Unify [x]) = daughter x - fromProfile (Unify args) = App "_U" (lmap daughter args) - fromProfile (Constant forest) = fromSyntaxForest forest + fromProfile :: Profile -> RExp + fromProfile [] = AMet + fromProfile [x] = daughter x + fromProfile args = App "_U" (lmap daughter args) daughter n = App "_A" [intToExp n] - fromSyntaxForest :: SyntaxForest CId -> RExp - fromSyntaxForest FMeta = AMet - -- FIXME: is there always just one element here? - fromSyntaxForest (FNode n [args]) = App (prCId n) (lmap fromSyntaxForest args) - fromSyntaxForest (FString s) = AStr s - fromSyntaxForest (FInt i) = AInt i - fromSyntaxForest (FFloat f) = AFlt f - fromSymbol :: FSymbol -> RExp fromSymbol (FSymCat c l n) = App "P" [intToExp c, intToExp n, intToExp l] fromSymbol (FSymTok t) = AStr t diff --git a/src-3.0/GF/Parsing/FCFG.hs b/src-3.0/GF/Parsing/FCFG.hs index 30a7801c8..b279caf48 100644 --- a/src-3.0/GF/Parsing/FCFG.hs +++ b/src-3.0/GF/Parsing/FCFG.hs @@ -46,7 +46,7 @@ parseFCF strategy pinfo startCat inString = let chart = fcfParser pinfo startCats inTokens (i,j) = inputBounds inTokens finalEdges = [makeFinalEdge cat i j | cat <- startCats] - forests = map cnv_forests $ chart2forests chart (const False) finalEdges + forests = chart2forests chart (const False) finalEdges filteredForests = forests >>= applyProfileToForest trees = nubsort $ filteredForests >>= forest2trees return $ map tree2term trees @@ -56,22 +56,6 @@ parseFCF strategy pinfo startCat inString = parseFCF "topdown" = Ok $ Active.parse "t" parseFCF strat = Bad $ "FCFG parsing strategy not defined: " ++ strat - -cnv_forests FMeta = FMeta -cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (CId 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 (CId n) fss) = FNode (CId 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 GFCC terms @@ -87,13 +71,13 @@ tree2term (TMeta) = exp0 -- conversion and unification of forests -- simplest implementation -applyProfileToForest :: SyntaxForest FName -> [SyntaxForest CId] -applyProfileToForest (FNode name@(Name fun profile) children) - | isCoercionF name = concat chForests - | otherwise = [ FNode fun chForests | not (null chForests) ] - where chForests = concat [ applyProfileM unifyManyForests profile forests | - forests0 <- children, - forests <- mapM applyProfileToForest forests0 ] +applyProfileToForest :: SyntaxForest (CId,[Profile]) -> [SyntaxForest CId] +applyProfileToForest (FNode (fun,profiles) children) + | fun == wildCId = concat chForests + | otherwise = [ FNode fun chForests | not (null chForests) ] + where chForests = concat [ mapM (unifyManyForests . map (forests !!)) profiles | + forests0 <- children, + forests <- mapM applyProfileToForest forests0 ] applyProfileToForest (FString s) = [FString s] applyProfileToForest (FInt n) = [FInt n] applyProfileToForest (FFloat f) = [FFloat f] diff --git a/src-3.0/GF/Parsing/FCFG/Active.hs b/src-3.0/GF/Parsing/FCFG/Active.hs index df55793f8..498054eee 100644 --- a/src-3.0/GF/Parsing/FCFG/Active.hs +++ b/src-3.0/GF/Parsing/FCFG/Active.hs @@ -14,6 +14,7 @@ import GF.Data.Assoc import GF.Data.SortedList import GF.Data.Utilities +import GF.GFCC.CId import GF.Formalism.FCFG import GF.Formalism.Utilities @@ -45,7 +46,7 @@ isTD s = s=="t" emptyChildren :: RuleId -> FCFPInfo -> SyntaxNode RuleId RangeRec emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) []) where - FRule _ rhs _ _ = allRules pinfo ! ruleid + FRule _ _ rhs _ _ = allRules pinfo ! ruleid process :: String -> FCFPInfo -> Input FToken -> [(FCat,Item)] -> XChart FCat -> XChart FCat process strategy pinfo toks [] chart = chart @@ -77,20 +78,20 @@ 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 fn _ cat lins) = allRules pinfo ! ruleid + (FRule _ _ _ 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 + let FRule _ _ _ _ lins = allRules pinfo ! ruleid FSymCat cat r d = lins ! l ! ppos rng <- concatRange rng (found' !! r) return (cat, Active found rng l (ppos+1) (updateChildren node d found')) ++ do guard (isBU strategy) ruleid <- leftcornerCats pinfo ? cat - let FRule _ _ _ lins = allRules pinfo ! ruleid + let FRule _ _ _ _ lins = allRules pinfo ! ruleid FSymCat cat r d = lins ! 0 ! 0 return (cat, Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid pinfo) d found')) @@ -128,12 +129,12 @@ insertXChart (XChart actives finals) item@(Final _ _) c = lookupXChartAct (XChart actives finals) c = chartLookup actives c lookupXChartFinal (XChart actives finals) c = chartLookup finals c -xchart2syntaxchart :: XChart FCat -> FCFPInfo -> SyntaxChart FName (FCat,RangeRec) +xchart2syntaxchart :: XChart FCat -> FCFPInfo -> SyntaxChart (CId,[Profile]) (FCat,RangeRec) xchart2syntaxchart (XChart actives finals) pinfo = accumAssoc groupSyntaxNodes $ [ case node of - SNode ruleid rrecs -> let FRule fun rhs cat _ = allRules pinfo ! ruleid - in ((cat,found), SNode fun (zip rhs rrecs)) + SNode ruleid rrecs -> let FRule fun prof rhs cat _ = allRules pinfo ! ruleid + in ((cat,found), SNode (fun,prof) (zip rhs rrecs)) SString s -> ((cat,found), SString s) SInt n -> ((cat,found), SInt n) SFloat f -> ((cat,found), SFloat f) @@ -170,10 +171,10 @@ initialBU :: FCFPInfo -> Input FToken -> [(FCat,Item)] initialBU pinfo toks = do (tok,rngs) <- aAssocs (inputToken toks) ruleid <- leftcornerTokens pinfo ? tok - let FRule _ _ cat _ = allRules pinfo ! ruleid + let FRule _ _ _ cat _ = allRules pinfo ! ruleid (i,j) <- rngs return (cat,Active [] (makeRange i j) 0 1 (emptyChildren ruleid pinfo)) ++ do ruleid <- epsilonRules pinfo - let FRule _ _ cat _ = allRules pinfo ! ruleid + let FRule _ _ _ cat _ = allRules pinfo ! ruleid return (cat,Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo)) diff --git a/src-3.0/GF/Parsing/FCFG/PInfo.hs b/src-3.0/GF/Parsing/FCFG/PInfo.hs index 8b288f2f1..dc934c1e5 100644 --- a/src-3.0/GF/Parsing/FCFG/PInfo.hs +++ b/src-3.0/GF/Parsing/FCFG/PInfo.hs @@ -15,7 +15,7 @@ import GF.Formalism.FCFG import GF.Data.SortedList import GF.Data.Assoc import GF.Parsing.FCFG.Range -import qualified GF.GFCC.CId as AbsGFCC +import GF.GFCC.CId import Data.Array import Data.Maybe @@ -30,7 +30,7 @@ import Debug.Trace type FCFParser = FCFPInfo -> [FCat] -> Input FToken - -> SyntaxChart FName (FCat,RangeRec) + -> SyntaxChart (CId,[Profile]) (FCat,RangeRec) makeFinalEdge cat 0 0 = (cat, [EmptyRange]) makeFinalEdge cat i j = (cat, [makeRange i j]) @@ -52,7 +52,7 @@ data FCFPInfo -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): , grammarCats :: SList FCat , grammarToks :: SList FToken - , startupCats :: Map.Map AbsGFCC.CId [FCat] + , startupCats :: Map.Map CId [FCat] } @@ -86,18 +86,17 @@ buildFCFPInfo (grammar,startup) = -- trace (unlines [prt (x,Set.toList set) | (x } where allrules = listArray (0,length grammar-1) grammar - topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ cat _) <- assocs allrules] - -- emptyrules = [ruleid | (ruleid, FRule _ [] _ _) <- assocs allrules] - epsilonrules = [ ruleid | (ruleid, FRule _ _ _ lins) <- assocs allrules, + topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ _ cat _) <- 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] fcfPInfoToFGrammar :: FCFPInfo -> FGrammar fcfPInfoToFGrammar pinfo = (elems (allRules pinfo), startupCats pinfo)