GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-23 09:52:55 -06:00
Code Issues Packages Projects Releases Wiki Activity

fix the molto-molto-molto problem

Browse Source
This commit is contained in:
krasimir
2010-04-12 13:55:40 +00:00
parent 541b578be8
commit 9377fd7c7c
1 changed files with 18 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

38
src/runtime/haskell/PGF/Macros.hs
View File

@@ -151,28 +151,27 @@ updateProductionIndices :: PGF -> PGF
updateProductionIndices pgf = pgf{ concretes = fmap updateConcrete (concretes pgf) } updateProductionIndices pgf = pgf{ concretes = fmap updateConcrete (concretes pgf) }
where where
updateConcrete cnc = updateConcrete cnc =
let prods0 = filterProductions (productions cnc) let p_prods = (filterProductions IntMap.empty . parseIndex cnc) (productions cnc)
p_prods = parseIndex cnc prods0 l_prods = (linIndex cnc . filterProductions IntMap.empty) (productions cnc)
l_prods = linIndex cnc prods0
in cnc{pproductions = p_prods, lproductions = l_prods} in cnc{pproductions = p_prods, lproductions = l_prods}
filterProductions prods0 filterProductions prods0 prods
| IntMap.size prods == IntMap.size prods0 = prods | prods0 == prods1 = prods0
| otherwise = filterProductions prods | otherwise = filterProductions prods1 prods
where where
prods = IntMap.mapMaybe (filterProdSet prods0) prods0 prods1 = IntMap.unionWith Set.union prods0 (IntMap.mapMaybe (filterProdSet prods0) prods)
filterProdSet prods set0 filterProdSet prods0 set
| Set.null set = Nothing | Set.null set1 = Nothing
| otherwise = Just set | otherwise = Just set1
where where
set = Set.filter (filterRule prods) set0 set1 = Set.filter (filterRule prods0) set
filterRule prods (PApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args filterRule prods0 (PApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods0) args
filterRule prods (PCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods filterRule prods0 (PCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods0
filterRule prods _ = True filterRule prods0 _ = True
parseIndex pinfo = IntMap.mapMaybeWithKey filterProdSet parseIndex cnc = IntMap.mapMaybeWithKey filterProdSet
where where
filterProdSet fid prods filterProdSet fid prods
| fid `IntSet.member` ho_fids = Just prods | fid `IntSet.member` ho_fids = Just prods
@@ -186,21 +185,20 @@ updateProductionIndices pgf = pgf{ concretes = fmap updateConcrete (concretes pg
ho_fids :: IntSet.IntSet ho_fids :: IntSet.IntSet
ho_fids = IntSet.fromList [fid | cat <- ho_cats ho_fids = IntSet.fromList [fid | cat <- ho_cats
, fid <- maybe [] (\(CncCat s e _) -> [s..e]) (Map.lookup cat (cnccats pinfo))] , fid <- maybe [] (\(CncCat s e _) -> [s..e]) (Map.lookup cat (cnccats cnc))]
ho_cats :: [CId] ho_cats :: [CId]
ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs (abstract pgf)) ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs (abstract pgf))
, h <- case ty of {DTyp hyps val _ -> hyps} , h <- case ty of {DTyp hyps val _ -> hyps}
, let ty = typeOfHypo h , c <- fst (catSkeleton (typeOfHypo h))]
, c <- fst (catSkeleton ty)]
linIndex pinfo productions = linIndex cnc productions =
Map.fromListWith (IntMap.unionWith Set.union) Map.fromListWith (IntMap.unionWith Set.union)
[(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions [(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions
, prod <- Set.toList prods , prod <- Set.toList prods
, fun <- getFunctions prod] , fun <- getFunctions prod]
where where
getFunctions (PApply funid args) = let CncFun fun _ = cncfuns pinfo Array.! funid in [fun] getFunctions (PApply funid args) = let CncFun fun _ = cncfuns cnc Array.! funid in [fun]
getFunctions (PCoerce fid) = case IntMap.lookup fid productions of getFunctions (PCoerce fid) = case IntMap.lookup fid productions of
Nothing -> [] Nothing -> []
Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod] Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod]