From 687173736ca2e15de259d98611a0bd0435a7bba8 Mon Sep 17 00:00:00 2001 From: krasimir Date: Thu, 29 May 2008 11:43:28 +0000 Subject: [PATCH] simplify FSymbol type --- src-3.0/GF/Compile/GenerateFCFG.hs | 4 ++-- src-3.0/GF/Formalism/FCFG.hs | 4 ++-- src-3.0/GF/GFCC/GFCCtoJS.hs | 2 +- src-3.0/GF/GFCC/Raw/ConvertGFCC.hs | 5 ++--- src-3.0/GF/Parsing/FCFG/Active.hs | 27 ++++++++++++++------------- src-3.0/GF/Parsing/FCFG/PInfo.hs | 24 ++++++++++-------------- 6 files changed, 31 insertions(+), 35 deletions(-) diff --git a/src-3.0/GF/Compile/GenerateFCFG.hs b/src-3.0/GF/Compile/GenerateFCFG.hs index 2ad45e25f..7fc75987f 100644 --- a/src-3.0/GF/Compile/GenerateFCFG.hs +++ b/src-3.0/GF/Compile/GenerateFCFG.hs @@ -163,7 +163,7 @@ translateLin idxArgs lbl' ((lbl,syms) : lins) instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) FSymTok instCat lbl nr xnr nr' ((idx,xargs):idxArgs) | nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr - in FSymCat fcat (index lbl rcs 0) (nr'+xnr) + in FSymCat (index lbl rcs 0) (nr'+xnr) | otherwise = instCat lbl nr xnr (nr'+length xargs) idxArgs index lbl' (lbl:lbls) idx @@ -337,7 +337,7 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs t = foldBM (\tcs st (either_fcat,last_id,tmap,rules) -> let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap 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]]) + (listArray (0,length rcs-1) [listArray (0,0) [FSymCat lbl 0] | lbl <- [0..length rcs-1]]) in if st then (Right fcat, last_id1,tmap1,rule:rules) else (either_fcat,last_id, tmap, rules)) diff --git a/src-3.0/GF/Formalism/FCFG.hs b/src-3.0/GF/Formalism/FCFG.hs index 96e88c8cf..91f954aca 100644 --- a/src-3.0/GF/Formalism/FCFG.hs +++ b/src-3.0/GF/Formalism/FCFG.hs @@ -59,7 +59,7 @@ fcatVar = (-4) -- Symbol type FIndex = Int data FSymbol - = FSymCat {-# UNPACK #-} !FCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int + = FSymCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int | FSymTok FToken @@ -78,7 +78,7 @@ instance Print CId where prt = prCId instance Print FSymbol where - prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")" + prt (FSymCat l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")" prt (FSymTok t) = simpleShow (prt t) where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\"" mkEsc '\\' = "\\\\" diff --git a/src-3.0/GF/GFCC/GFCCtoJS.hs b/src-3.0/GF/GFCC/GFCCtoJS.hs index abf7e45a9..e55655796 100644 --- a/src-3.0/GF/GFCC/GFCCtoJS.hs +++ b/src-3.0/GF/GFCC/GFCCtoJS.hs @@ -113,7 +113,7 @@ lins2js :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls] sym2js :: FSymbol -> JS.Expr -sym2js (FSymCat _ l n) = new "ArgProj" [JS.EInt n, JS.EInt l] +sym2js (FSymCat l n) = new "ArgProj" [JS.EInt n, JS.EInt l] sym2js (FSymTok t) = new "Terminal" [JS.EStr t] new :: String -> [JS.Expr] -> JS.Expr diff --git a/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs index 324f8be04..cebc06a31 100644 --- a/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs +++ b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs @@ -5,7 +5,6 @@ import GF.GFCC.DataGFCC import GF.GFCC.Raw.AbsGFCCRaw import GF.Infra.PrintClass -import GF.Data.Assoc import GF.Formalism.FCFG import GF.Formalism.Utilities import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo) @@ -95,7 +94,7 @@ toFName (App f ts) = (mkCId f, lmap toProfile ts) 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) +toSymbol (App "P" [n,l]) = FSymCat (expToInt l) (expToInt n) toSymbol (AStr t) = FSymTok t toType :: RExp -> Type @@ -231,7 +230,7 @@ fromFName (f,ps) | f == wildCId = fromProfile (head ps) daughter n = App "_A" [intToExp n] fromSymbol :: FSymbol -> RExp -fromSymbol (FSymCat c l n) = App "P" [intToExp c, intToExp n, intToExp l] +fromSymbol (FSymCat l n) = App "P" [intToExp n, intToExp l] fromSymbol (FSymTok t) = AStr t -- ** Utilities diff --git a/src-3.0/GF/Parsing/FCFG/Active.hs b/src-3.0/GF/Parsing/FCFG/Active.hs index 9d4a0ac0c..7db4fbb61 100644 --- a/src-3.0/GF/Parsing/FCFG/Active.hs +++ b/src-3.0/GF/Parsing/FCFG/Active.hs @@ -54,7 +54,8 @@ process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks univRule cat item@(Active found rng lbl ppos node@(SNode ruleid recs)) chart | inRange (bounds lin) ppos = case lin ! ppos of - FSymCat c r d -> case recs !! d of + FSymCat r d -> let c = args !! d + in case recs !! d of [] -> case insertXChart chart item c of Nothing -> chart Just chart -> let items = do item@(Final found' _) <- lookupXChartFinal chart c @@ -68,31 +69,31 @@ process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks found' -> let items = do rng <- concatRange rng (found' !! r) return (c, Active found rng lbl (ppos+1) node) in process strategy pinfo toks items chart - FSymTok tok -> let items = do t_rng <- inputToken toks ? tok - rng' <- concatRange rng t_rng - return (cat, Active found rng' lbl (ppos+1) node) - in process strategy pinfo toks items chart + FSymTok tok -> let items = do t_rng <- inputToken toks ? tok + rng' <- concatRange rng t_rng + return (cat, Active found rng' lbl (ppos+1) node) + in process strategy pinfo toks items chart | otherwise = if inRange (bounds lins) (lbl+1) then univRule cat (Active (rng:found) EmptyRange (lbl+1) 0 node) chart else univRule cat (Final (reverse (rng:found)) node) chart where - (FRule _ _ _ cat lins) = allRules pinfo ! ruleid - lin = lins ! lbl + (FRule _ _ args 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 _ _ args _ lins = allRules pinfo ! ruleid + FSymCat r d = lins ! l ! ppos rng <- concatRange rng (found' !! r) - return (cat, Active found rng l (ppos+1) (updateChildren node d found')) + return (args !! d, Active found rng l (ppos+1) (updateChildren node d found')) ++ do guard (isBU strategy) ruleid <- leftcornerCats pinfo ? cat - 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')) + let FRule _ _ args _ lins = allRules pinfo ! ruleid + FSymCat r d = lins ! 0 ! 0 + return (args !! d, Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid pinfo) d found')) updateChildren :: SyntaxNode RuleId RangeRec -> Int -> RangeRec -> SyntaxNode RuleId RangeRec updateChildren (SNode ruleid recs) i rec = SNode ruleid $! updateNth (const rec) i recs diff --git a/src-3.0/GF/Parsing/FCFG/PInfo.hs b/src-3.0/GF/Parsing/FCFG/PInfo.hs index 08d40df85..2d6385feb 100644 --- a/src-3.0/GF/Parsing/FCFG/PInfo.hs +++ b/src-3.0/GF/Parsing/FCFG/PInfo.hs @@ -55,19 +55,19 @@ data FCFPInfo } -getLeftCornerTok lins +getLeftCornerTok (FRule _ _ _ _ lins) | inRange (bounds syms) 0 = case syms ! 0 of - FSymTok tok -> Just tok - _ -> Nothing - | otherwise = Nothing + FSymTok tok -> [tok] + _ -> [] + | otherwise = [] where syms = lins ! 0 -getLeftCornerCat lins +getLeftCornerCat (FRule _ _ args _ lins) | inRange (bounds syms) 0 = case syms ! 0 of - FSymCat c _ _ -> Just c - _ -> Nothing - | otherwise = Nothing + FSymCat _ d -> [args !! d] + _ -> [] + | otherwise = [] where syms = lins ! 0 @@ -88,12 +88,8 @@ buildFCFPInfo (grammar,startup) = -- trace (unlines [prt (x,Set.toList set) | (x 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) ] - leftcorntoks = accumAssoc id - [ (fromJust (getLeftCornerTok lins), ruleid) | - (ruleid, FRule _ _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ] + leftcorncats = accumAssoc id [ (cat, ruleid) | (ruleid, rule) <- assocs allrules, cat <- getLeftCornerCat rule ] + leftcorntoks = accumAssoc id [ (tok, ruleid) | (ruleid, rule) <- assocs allrules, tok <- getLeftCornerTok rule ] grammarcats = aElems topdownrules grammartoks = nubsort [t | (FRule _ _ _ _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin]