GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

simplify the Profile type and remove the NameProfile type

Browse Source
This commit is contained in:
krasimir
2008-05-29 10:55:34 +00:00
parent 45e1eedff3
commit 64d3a1226d
8 changed files with 74 additions and 195 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
src-3.0/GF/Compile/GenerateFCFG.hs
View File

@@ -97,9 +97,9 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
-- replaces __NCat with _B and _Var_Cat with _. -- replaces __NCat with _B and _Var_Cat with _.
-- the temporary names are just there to avoid name collisions. -- the temporary names are just there to avoid name collisions.
fixHoasFuns :: FGrammar -> FGrammar fixHoasFuns :: FGrammar -> FGrammar
fixHoasFuns (rs, cs) = ([FRule (fixName n) args cat lins | FRule n args cat lins <- rs], cs) fixHoasFuns (rs, cs) = ([FRule (fixName n) ps args cat lins | FRule n ps args cat lins <- rs], cs)
where fixName (Name (CId n) p) | BS.pack "__" `BS.isPrefixOf` n = Name (mkCId "_B") p where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B")
| BS.pack "_Var_" `BS.isPrefixOf` n = Name wildCId p | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
fixName n = n fixName n = n
convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar 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' (_,newProfile) = List.mapAccumL accumProf 0 newArgs'
where where
accumProf nr (PFCat _ [] _,_ ) = (nr, Unify [] ) accumProf nr (PFCat _ [] _,_ ) = (nr, [] )
accumProf nr (_ ,xpaths) = (nr+cnt+1, Unify [nr..nr+cnt]) accumProf nr (_ ,xpaths) = (nr+cnt+1, [nr..nr+cnt])
where cnt = length xpaths where cnt = length xpaths
rule = FRule (Name fun newProfile) newArgs newCat newLinRec rule = FRule fun newProfile newArgs newCat newLinRec
in addFRule env2 rule in addFRule env2 rule
translateLin idxArgs lbl' [] = array (0,-1) [] 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) (either_fcat,last_id1,tmap1,rules1)
= foldBM (\tcs st (either_fcat,last_id,tmap,rules) -> = foldBM (\tcs st (either_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 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]]) (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)

34
src-3.0/GF/Formalism/FCFG.hs
View File

@@ -22,11 +22,8 @@ module GF.Formalism.FCFG
, FIndex , FIndex
, FSymbol(..) , FSymbol(..)
-- * Name
, FName
, isCoercionF
-- * Grammar -- * Grammar
, Profile
, FPointPos , FPointPos
, FGrammar , FGrammar
, FRule(..) , FRule(..)
@@ -38,7 +35,7 @@ import Data.Array
import qualified Data.Map as Map import qualified Data.Map as Map
import GF.Formalism.Utilities import GF.Formalism.Utilities
import qualified GF.GFCC.CId as AbsGFCC import GF.GFCC.CId
import GF.Infra.PrintClass import GF.Infra.PrintClass
------------------------------------------------------------ ------------------------------------------------------------
@@ -66,27 +63,19 @@ data FSymbol
| FSymTok FToken | FSymTok FToken
------------------------------------------------------------
-- Name
type FName = NameProfile AbsGFCC.CId
isCoercionF :: FName -> Bool
isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.wildCId
isCoercionF _ = False
------------------------------------------------------------ ------------------------------------------------------------
-- Grammar -- Grammar
type Profile = [Int]
type FPointPos = Int type FPointPos = Int
type FGrammar = ([FRule], Map.Map AbsGFCC.CId [FCat]) type FGrammar = ([FRule], Map.Map CId [FCat])
data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol)) data FRule = FRule CId [Profile] [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
------------------------------------------------------------ ------------------------------------------------------------
-- pretty-printing -- pretty-printing
instance Print AbsGFCC.CId where instance Print CId where
prt = AbsGFCC.prCId prt = prCId
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 ++ ")"
@@ -100,6 +89,11 @@ instance Print FSymbol where
prtList = prtSep " " prtList = prtSep " "
instance Print FRule where instance Print FRule where
prt (FRule name args res lins) = prt name ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++ prt (FRule fun profile args res lins) =
" =\n [" ++ prtSep "\n " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs 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" prtList = prtSep "\n"

70
src-3.0/GF/Formalism/Utilities.hs
View File

@@ -309,66 +309,6 @@ forest2trees (FMeta) = [TMeta]
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- * profiles -- * 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 -- pretty-printing
@@ -411,13 +351,3 @@ instance (Print s) => Print (SyntaxForest s) where
prt (FFloat f) = show f prt (FFloat f) = show f
prt (FMeta) = "?" prt (FMeta) = "?"
prtList = prtAfter "\n" 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

27
src-3.0/GF/GFCC/GFCCtoJS.hs
View File

@@ -8,7 +8,6 @@ import qualified GF.JavaScript.PrintJS as JS
import GF.Formalism.FCFG import GF.Formalism.FCFG
import GF.Parsing.FCFG.PInfo import GF.Parsing.FCFG.PInfo
import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..))
import GF.Text.UTF8 import GF.Text.UTF8
import GF.Data.ErrM 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)) cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is))
frule2js :: FRule -> JS.Expr 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 :: (CId,[Profile]) -> JS.Expr
name2js n = case n of name2js (f,ps) | f == wildCId = fromProfile (head ps)
Name f [p] | f == wildCId -> fromProfile p | otherwise = new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
where where
fromProfile :: Profile (SyntaxForest CId) -> JS.Expr fromProfile :: Profile -> JS.Expr
fromProfile (Unify []) = new "MetaVar" [] fromProfile [] = new "MetaVar" []
fromProfile (Unify [x]) = daughter x fromProfile [x] = daughter x
fromProfile (Unify args) = new "Unify" [JS.EArray (map daughter args)] fromProfile args = new "Unify" [JS.EArray (map daughter args)]
fromProfile (Constant forest) = fromSyntaxForest forest
daughter i = new "Arg" [JS.EInt i] 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 :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr
lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls] lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls]

56
src-3.0/GF/GFCC/Raw/ConvertGFCC.hs
View File

@@ -7,7 +7,7 @@ import GF.GFCC.Raw.AbsGFCCRaw
import GF.Infra.PrintClass import GF.Infra.PrintClass
import GF.Data.Assoc import GF.Data.Assoc
import GF.Formalism.FCFG import GF.Formalism.FCFG
import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..)) import GF.Formalism.Utilities
import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo) import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo)
import qualified Data.Array as Array import qualified Data.Array as Array
@@ -78,29 +78,21 @@ toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats)
toFRule (App "rule" toFRule (App "rule"
[n, [n,
App "cats" (rt:at), App "cats" (rt:at),
App "R" ls]) = FRule name args res lins App "R" ls]) = FRule fun prof args res lins
where where
name = toFName n (fun,prof) = toFName n
args = lmap expToInt at args = lmap expToInt at
res = expToInt rt res = expToInt rt
lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls] lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls]
toFName :: RExp -> FName toFName :: RExp -> (CId,[Profile])
toFName (App "_A" [x]) = Name wildCId [Unify [expToInt x]] toFName (App "_A" [x]) = (wildCId, [[expToInt x]])
toFName (App f ts) = Name (mkCId f) (lmap toProfile ts) toFName (App f ts) = (mkCId f, lmap toProfile ts)
where where
toProfile :: RExp -> Profile (SyntaxForest CId) toProfile :: RExp -> Profile
toProfile AMet = Unify [] toProfile AMet = []
toProfile (App "_A" [t]) = Unify [expToInt t] toProfile (App "_A" [t]) = [expToInt t]
toProfile (App "_U" ts) = Unify [expToInt t | App "_A" [t] <- ts] toProfile (App "_U" ts) = [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
toSymbol :: RExp -> FSymbol toSymbol :: RExp -> FSymbol
toSymbol (App "P" [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n) 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 -> RExp
fromFRule (FRule n args res lins) = fromFRule (FRule fun prof args res lins) =
App "rule" [fromFName n, App "rule" [fromFName (fun,prof),
App "cats" (intToExp res:lmap intToExp args), App "cats" (intToExp res:lmap intToExp args),
App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins] App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
] ]
fromFName :: FName -> RExp fromFName :: (CId,[Profile]) -> RExp
fromFName n = case n of fromFName (f,ps) | f == wildCId = fromProfile (head ps)
Name f ps | f == wildCId -> fromProfile (head ps) | otherwise = App (prCId f) (lmap fromProfile ps)
| otherwise -> App (prCId f) (lmap fromProfile ps)
where where
fromProfile :: Profile (SyntaxForest CId) -> RExp fromProfile :: Profile -> RExp
fromProfile (Unify []) = AMet fromProfile [] = AMet
fromProfile (Unify [x]) = daughter x fromProfile [x] = daughter x
fromProfile (Unify args) = App "_U" (lmap daughter args) fromProfile args = App "_U" (lmap daughter args)
fromProfile (Constant forest) = fromSyntaxForest forest
daughter n = App "_A" [intToExp n] 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 :: FSymbol -> RExp
fromSymbol (FSymCat c l n) = App "P" [intToExp c, intToExp n, intToExp l] fromSymbol (FSymCat c l n) = App "P" [intToExp c, intToExp n, intToExp l]
fromSymbol (FSymTok t) = AStr t fromSymbol (FSymTok t) = AStr t

32
src-3.0/GF/Parsing/FCFG.hs
View File

@@ -46,7 +46,7 @@ parseFCF strategy pinfo startCat inString =
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]
forests = map cnv_forests $ chart2forests chart (const False) finalEdges forests = chart2forests chart (const False) finalEdges
filteredForests = forests >>= applyProfileToForest filteredForests = forests >>= applyProfileToForest
trees = nubsort $ filteredForests >>= forest2trees trees = nubsort $ filteredForests >>= forest2trees
return $ map tree2term trees return $ map tree2term trees
@@ -56,22 +56,6 @@ parseFCF strategy pinfo startCat inString =
parseFCF "topdown" = Ok $ Active.parse "t" parseFCF "topdown" = Ok $ Active.parse "t"
parseFCF strat = Bad $ "FCFG parsing strategy not defined: " ++ strat 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 -- parse trees to GFCC terms
@@ -87,13 +71,13 @@ tree2term (TMeta) = exp0
-- conversion and unification of forests -- conversion and unification of forests
-- simplest implementation -- simplest implementation
applyProfileToForest :: SyntaxForest FName -> [SyntaxForest CId] applyProfileToForest :: SyntaxForest (CId,[Profile]) -> [SyntaxForest CId]
applyProfileToForest (FNode name@(Name fun profile) children) applyProfileToForest (FNode (fun,profiles) children)
| isCoercionF name = concat chForests | fun == wildCId = concat chForests
| otherwise = [ FNode fun chForests | not (null chForests) ] | otherwise = [ FNode fun chForests | not (null chForests) ]
where chForests = concat [ applyProfileM unifyManyForests profile forests | where chForests = concat [ mapM (unifyManyForests . map (forests !!)) profiles |
forests0 <- children, forests0 <- children,
forests <- mapM applyProfileToForest forests0 ] forests <- mapM applyProfileToForest forests0 ]
applyProfileToForest (FString s) = [FString s] applyProfileToForest (FString s) = [FString s]
applyProfileToForest (FInt n) = [FInt n] applyProfileToForest (FInt n) = [FInt n]
applyProfileToForest (FFloat f) = [FFloat f] applyProfileToForest (FFloat f) = [FFloat f]

19
src-3.0/GF/Parsing/FCFG/Active.hs
View File

@@ -14,6 +14,7 @@ import GF.Data.Assoc
import GF.Data.SortedList import GF.Data.SortedList
import GF.Data.Utilities import GF.Data.Utilities
import GF.GFCC.CId
import GF.Formalism.FCFG import GF.Formalism.FCFG
import GF.Formalism.Utilities import GF.Formalism.Utilities
@@ -45,7 +46,7 @@ isTD s = s=="t"
emptyChildren :: RuleId -> FCFPInfo -> SyntaxNode RuleId RangeRec emptyChildren :: RuleId -> FCFPInfo -> SyntaxNode RuleId RangeRec
emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) []) emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) [])
where where
FRule _ rhs _ _ = allRules pinfo ! ruleid FRule _ _ rhs _ _ = allRules pinfo ! ruleid
process :: String -> FCFPInfo -> Input FToken -> [(FCat,Item)] -> XChart FCat -> XChart FCat process :: String -> FCFPInfo -> Input FToken -> [(FCat,Item)] -> XChart FCat -> XChart FCat
process strategy pinfo toks [] chart = chart 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 then univRule cat (Active (rng:found) EmptyRange (lbl+1) 0 node) chart
else univRule cat (Final (reverse (rng:found)) node) chart else univRule cat (Final (reverse (rng:found)) node) chart
where where
(FRule fn _ cat lins) = allRules pinfo ! ruleid (FRule _ _ _ cat lins) = allRules pinfo ! ruleid
lin = lins ! lbl lin = lins ! lbl
univRule cat item@(Final found' node) chart = univRule cat item@(Final found' node) chart =
case insertXChart chart item cat of case insertXChart chart item cat of
Nothing -> chart Nothing -> chart
Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat
let FRule _ _ _ lins = allRules pinfo ! ruleid let FRule _ _ _ _ lins = allRules pinfo ! ruleid
FSymCat cat r d = lins ! l ! ppos FSymCat cat r d = lins ! l ! ppos
rng <- concatRange rng (found' !! r) rng <- concatRange rng (found' !! r)
return (cat, Active found rng l (ppos+1) (updateChildren node d found')) return (cat, Active found rng l (ppos+1) (updateChildren node d found'))
++ ++
do guard (isBU strategy) do guard (isBU strategy)
ruleid <- leftcornerCats pinfo ? cat ruleid <- leftcornerCats pinfo ? cat
let FRule _ _ _ lins = allRules pinfo ! ruleid let FRule _ _ _ _ lins = allRules pinfo ! ruleid
FSymCat cat r d = lins ! 0 ! 0 FSymCat cat r d = lins ! 0 ! 0
return (cat, Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid pinfo) d found')) 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 lookupXChartAct (XChart actives finals) c = chartLookup actives c
lookupXChartFinal (XChart actives finals) c = chartLookup finals 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 = xchart2syntaxchart (XChart actives finals) pinfo =
accumAssoc groupSyntaxNodes $ accumAssoc groupSyntaxNodes $
[ case node of [ case node of
SNode ruleid rrecs -> let FRule fun rhs cat _ = allRules pinfo ! ruleid SNode ruleid rrecs -> let FRule fun prof rhs cat _ = allRules pinfo ! ruleid
in ((cat,found), SNode fun (zip rhs rrecs)) in ((cat,found), SNode (fun,prof) (zip rhs rrecs))
SString s -> ((cat,found), SString s) SString s -> ((cat,found), SString s)
SInt n -> ((cat,found), SInt n) SInt n -> ((cat,found), SInt n)
SFloat f -> ((cat,found), SFloat f) SFloat f -> ((cat,found), SFloat f)
@@ -170,10 +171,10 @@ initialBU :: FCFPInfo -> Input FToken -> [(FCat,Item)]
initialBU pinfo toks = initialBU pinfo toks =
do (tok,rngs) <- aAssocs (inputToken toks) do (tok,rngs) <- aAssocs (inputToken toks)
ruleid <- leftcornerTokens pinfo ? tok ruleid <- leftcornerTokens pinfo ? tok
let FRule _ _ cat _ = allRules pinfo ! ruleid let FRule _ _ _ cat _ = allRules pinfo ! ruleid
(i,j) <- rngs (i,j) <- rngs
return (cat,Active [] (makeRange i j) 0 1 (emptyChildren ruleid pinfo)) return (cat,Active [] (makeRange i j) 0 1 (emptyChildren ruleid pinfo))
++ ++
do ruleid <- epsilonRules 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)) return (cat,Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo))

17
src-3.0/GF/Parsing/FCFG/PInfo.hs
View File

@@ -15,7 +15,7 @@ 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.CId as AbsGFCC import GF.GFCC.CId
import Data.Array import Data.Array
import Data.Maybe import Data.Maybe
@@ -30,7 +30,7 @@ import Debug.Trace
type FCFParser = FCFPInfo type FCFParser = FCFPInfo
-> [FCat] -> [FCat]
-> Input FToken -> Input FToken
-> SyntaxChart FName (FCat,RangeRec) -> SyntaxChart (CId,[Profile]) (FCat,RangeRec)
makeFinalEdge cat 0 0 = (cat, [EmptyRange]) makeFinalEdge cat 0 0 = (cat, [EmptyRange])
makeFinalEdge cat i j = (cat, [makeRange i j]) makeFinalEdge cat i j = (cat, [makeRange i j])
@@ -52,7 +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] , 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 where allrules = listArray (0,length grammar-1) grammar
topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ cat _) <- 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,
epsilonrules = [ ruleid | (ruleid, FRule _ _ _ lins) <- assocs allrules,
not (inRange (bounds (lins ! 0)) 0) ] not (inRange (bounds (lins ! 0)) 0) ]
leftcorncats = accumAssoc id leftcorncats = accumAssoc id
[ (fromJust (getLeftCornerCat lins), ruleid) | [ (fromJust (getLeftCornerCat lins), ruleid) |
(ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ] (ruleid, FRule _ _ _ _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ]
leftcorntoks = accumAssoc id leftcorntoks = accumAssoc id
[ (fromJust (getLeftCornerTok lins), ruleid) | [ (fromJust (getLeftCornerTok lins), ruleid) |
(ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ] (ruleid, FRule _ _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ]
grammarcats = aElems topdownrules grammarcats = aElems topdownrules
grammartoks = nubsort [t | (FRule _ _ _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin] grammartoks = nubsort [t | (FRule _ _ _ _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin]
fcfPInfoToFGrammar :: FCFPInfo -> FGrammar fcfPInfoToFGrammar :: FCFPInfo -> FGrammar
fcfPInfoToFGrammar pinfo = (elems (allRules pinfo), startupCats pinfo) fcfPInfoToFGrammar pinfo = (elems (allRules pinfo), startupCats pinfo)