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

fixed bug with variants in GF.Conversion.RemoveErasing

Browse Source
This commit is contained in:
peb
2006-03-21 06:18:03 +00:00
parent ab8edebcee
commit 6d13bb9e3c
1 changed files with 8 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
src/GF/Conversion/RemoveErasing.hs
View File

@@ -57,9 +57,11 @@ newRules grammar chart (NR (Rule (Abs _ cats _) _))
newRules grammar chart (NC newCat@(MCat cat lbls)) newRules grammar chart (NC newCat@(MCat cat lbls))
= do Rule (Abs _ args (Name fun profile)) (Cnc _ _ lins0) <- grammar ? cat = do Rule (Abs _ args (Name fun profile)) (Cnc _ _ lins0) <- grammar ? cat
let lins = [ lin | lin@(Lin lbl _) <- lins0, lins <- selectLins lins0 lbls
lbl `elem` lbls ] -- let lins = [ lin | lin@(Lin lbl _) <- lins0,
argsInLin = listAssoc $ -- lbl `elem` lbls ]
let argsInLin = listAssoc $
map (\((n,c),l) -> (n, MCat c l)) $ map (\((n,c),l) -> (n, MCat c l)) $
groupPairs $ nubsort $ groupPairs $ nubsort $
[ ((nr, cat), lbl) | [ ((nr, cat), lbl) |
@@ -86,6 +88,9 @@ newRules grammar chart (NC newCat@(MCat cat lbls))
guard $ all (not . null) argLbls guard $ all (not . null) argLbls
return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins)) return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins))
selectLins lins0 = mapM selectLbl
where selectLbl lbl = [ lin | lin@(Lin lbl' _) <- lins0, lbl == lbl' ]
prtNewName :: [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] -> Name -> String prtNewName :: [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] -> Name -> String
prtNewName p p' n = prt p ++ " .o. " ++ prt p' ++ " : " ++ prt n prtNewName p p' n = prt p ++ " .o. " ++ prt p' ++ " : " ++ prt n