forked from GitHub/gf-core
move the PGF optimizer in the compiler
This commit is contained in:
Krasimir Angelov
189
src/compiler/GF/Compile/OptimizePGF.hs
Normal file
189
src/compiler/GF/Compile/OptimizePGF.hs
Normal file
@@ -0,0 +1,189 @@
|
|||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
module GF.Compile.OptimizePGF(optimizePGF) where
|
||||||
|
|
||||||
|
import PGF(mkCId)
|
||||||
|
import PGF.Internal
|
||||||
|
import Data.Array.ST
|
||||||
|
import Data.Array.Unboxed
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import qualified Data.IntSet as IntSet
|
||||||
|
import qualified Data.IntMap as IntMap
|
||||||
|
import qualified Data.List as List
|
||||||
|
import Control.Monad.ST
|
||||||
|
|
||||||
|
type ConcrData = ([(FId,[FunId])], -- ^ Lindefs
|
||||||
|
[(FId,[FunId])], -- ^ Linrefs
|
||||||
|
[(FId,[Production])], -- ^ Productions
|
||||||
|
[(CId,[SeqId])], -- ^ Concrete functions (must be sorted by Fun)
|
||||||
|
[[Symbol]], -- ^ Sequences (must be sorted)
|
||||||
|
[(CId,FId,FId,[String])]) -- ^ Concrete categories
|
||||||
|
|
||||||
|
optimizePGF :: CId -> ConcrData -> ConcrData
|
||||||
|
optimizePGF startCat = topDownFilter startCat . bottomUpFilter
|
||||||
|
|
||||||
|
cidString = mkCId "String"
|
||||||
|
cidInt = mkCId "Int"
|
||||||
|
cidFloat = mkCId "Float"
|
||||||
|
cidVar = mkCId "__gfVar"
|
||||||
|
|
||||||
|
topDownFilter :: CId -> ConcrData -> ConcrData
|
||||||
|
topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
|
||||||
|
let env0 = (Map.empty,Map.empty)
|
||||||
|
(env1,lindefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids in (env',(fid,funids')))
|
||||||
|
env0
|
||||||
|
lindefs
|
||||||
|
(env2,linrefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fidVar [PArg [] fid]) env funids in (env',(fid,funids')))
|
||||||
|
env1
|
||||||
|
linrefs
|
||||||
|
(env3,prods') = List.mapAccumL (\env (fid,set) -> let (env',set') = List.mapAccumL (optimizeProd fid) env set in (env',(fid,set')))
|
||||||
|
env2
|
||||||
|
prods
|
||||||
|
cnccats' = map filterCatLabels cnccats
|
||||||
|
(sequences',cncfuns') = env3
|
||||||
|
in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray sequences',cnccats')
|
||||||
|
where
|
||||||
|
cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (CId, [SeqId])
|
||||||
|
sequences_array = listArray (0,length sequences-1) sequences :: Array SeqId [Symbol]
|
||||||
|
prods_map = IntMap.fromList prods
|
||||||
|
fid2catMap = IntMap.fromList ((fidVar,cidVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats,
|
||||||
|
fid <- [start..end]])
|
||||||
|
|
||||||
|
fid2cat fid =
|
||||||
|
case IntMap.lookup fid fid2catMap of
|
||||||
|
Just cat -> cat
|
||||||
|
Nothing -> case [fid | Just set <- [IntMap.lookup fid prods_map], PCoerce fid <- set] of
|
||||||
|
(fid:_) -> fid2cat fid
|
||||||
|
_ -> error "unknown forest id"
|
||||||
|
|
||||||
|
starts =
|
||||||
|
[(startCat,lbl) | (cat,_,_,lbls) <- cnccats, cat==startCat, lbl <- [0..length lbls-1]]
|
||||||
|
|
||||||
|
allRelations =
|
||||||
|
Map.unionsWith Set.union
|
||||||
|
[rel fid prod | (fid,set) <- prods, prod <- set]
|
||||||
|
where
|
||||||
|
rel fid (PApply funid args) = Map.fromList [((fid2cat fid,lbl),deps args seqid) | (lbl,seqid) <- zip [0..] lin]
|
||||||
|
where
|
||||||
|
(_,lin) = cncfuns_array ! funid
|
||||||
|
rel fid _ = Map.empty
|
||||||
|
|
||||||
|
deps args seqid = Set.fromList [let PArg _ fid = args !! r in (fid2cat fid,d) | SymCat r d <- seq]
|
||||||
|
where
|
||||||
|
seq = sequences_array ! seqid
|
||||||
|
|
||||||
|
-- here we create a mapping from a category to an array of indices.
|
||||||
|
-- An element of the array is equal to -1 if the corresponding index
|
||||||
|
-- is not going to be used in the optimized grammar, or the new index
|
||||||
|
-- if it will be used
|
||||||
|
closure :: Map.Map CId [LIndex]
|
||||||
|
closure = runST $ do
|
||||||
|
set <- initSet
|
||||||
|
addLitCat cidString set
|
||||||
|
addLitCat cidInt set
|
||||||
|
addLitCat cidFloat set
|
||||||
|
addLitCat cidVar set
|
||||||
|
closureSet set starts
|
||||||
|
doneSet set
|
||||||
|
where
|
||||||
|
initSet :: ST s (Map.Map CId (STUArray s LIndex LIndex))
|
||||||
|
initSet =
|
||||||
|
fmap Map.fromList $ sequence
|
||||||
|
[fmap ((,) cat) (newArray (0,length lbls-1) (-1))
|
||||||
|
| (cat,_,_,lbls) <- cnccats]
|
||||||
|
|
||||||
|
addLitCat cat set =
|
||||||
|
case Map.lookup cat set of
|
||||||
|
Just indices -> writeArray indices 0 0
|
||||||
|
Nothing -> return ()
|
||||||
|
|
||||||
|
closureSet set [] = return ()
|
||||||
|
closureSet set (x@(cat,index):xs) =
|
||||||
|
case Map.lookup cat set of
|
||||||
|
Just indices -> do v <- readArray indices index
|
||||||
|
writeArray indices index 0
|
||||||
|
if v < 0
|
||||||
|
then case Map.lookup x allRelations of
|
||||||
|
Just ys -> closureSet set (Set.toList ys++xs)
|
||||||
|
Nothing -> closureSet set xs
|
||||||
|
else closureSet set xs
|
||||||
|
Nothing -> error "unknown cat"
|
||||||
|
|
||||||
|
doneSet :: Map.Map CId (STUArray s LIndex LIndex) -> ST s (Map.Map CId [LIndex])
|
||||||
|
doneSet set =
|
||||||
|
fmap Map.fromAscList $ mapM done (Map.toAscList set)
|
||||||
|
where
|
||||||
|
done (cat,indices) = do
|
||||||
|
indices <- fmap (reindex 0) (getElems indices)
|
||||||
|
return (cat,indices)
|
||||||
|
|
||||||
|
reindex k [] = []
|
||||||
|
reindex k (v:vs)
|
||||||
|
| v < 0 = v : reindex k vs
|
||||||
|
| otherwise = k : reindex (k+1) vs
|
||||||
|
|
||||||
|
optimizeProd res env (PApply funid args) =
|
||||||
|
let (env',funid') = optimizeFun res args env funid
|
||||||
|
in (env', PApply funid' args)
|
||||||
|
optimizeProd res env prod = (env,prod)
|
||||||
|
|
||||||
|
optimizeFun res args (seqs,funs) funid =
|
||||||
|
let (seqs',lin') = List.mapAccumL addUnique seqs [map updateSymbol (sequences_array ! seqid) |
|
||||||
|
(idx,seqid) <- zip (indicesOf res) lin, idx >= 0]
|
||||||
|
(funs',funid') = addUnique funs (fun, lin')
|
||||||
|
in ((seqs',funs'), funid')
|
||||||
|
where
|
||||||
|
(fun,lin) = cncfuns_array ! funid
|
||||||
|
|
||||||
|
indicesOf fid
|
||||||
|
| fid < 0 = [0]
|
||||||
|
| otherwise =
|
||||||
|
case Map.lookup (fid2cat fid) closure of
|
||||||
|
Just indices -> indices
|
||||||
|
Nothing -> error "unknown category"
|
||||||
|
|
||||||
|
addUnique seqs seq =
|
||||||
|
case Map.lookup seq seqs of
|
||||||
|
Just seqid -> (seqs,seqid)
|
||||||
|
Nothing -> let seqid = Map.size seqs
|
||||||
|
in (Map.insert seq seqid seqs, seqid)
|
||||||
|
|
||||||
|
updateSymbol (SymCat r d) = let PArg _ fid = args !! r in SymCat r (indicesOf fid !! d)
|
||||||
|
updateSymbol s = s
|
||||||
|
|
||||||
|
filterCatLabels (cat,start,end,lbls) =
|
||||||
|
case Map.lookup cat closure of
|
||||||
|
Just indices -> let lbls' = [lbl | (idx,lbl) <- zip indices lbls, idx >= 0]
|
||||||
|
in (cat,start,end,lbls')
|
||||||
|
Nothing -> error ("unknown category")
|
||||||
|
|
||||||
|
mkSetArray map = sortSnd (Map.toList map)
|
||||||
|
where
|
||||||
|
sortSnd = List.map fst . List.sortBy (\(_,i) (_,j) -> compare i j)
|
||||||
|
|
||||||
|
|
||||||
|
bottomUpFilter :: ConcrData -> ConcrData
|
||||||
|
bottomUpFilter (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
|
||||||
|
(lindefs,linrefs,filterProductions IntMap.empty IntSet.empty prods,cncfuns,sequences,cnccats)
|
||||||
|
|
||||||
|
filterProductions prods0 hoc0 prods
|
||||||
|
| prods0 == prods1 = IntMap.toList prods0
|
||||||
|
| otherwise = filterProductions prods1 hoc1 prods
|
||||||
|
where
|
||||||
|
(prods1,hoc1) = foldl foldProdSet (IntMap.empty,IntSet.empty) prods
|
||||||
|
|
||||||
|
foldProdSet (!prods,!hoc) (fid,set)
|
||||||
|
| null set1 = (prods,hoc)
|
||||||
|
| otherwise = (IntMap.insert fid set1 prods,hoc1)
|
||||||
|
where
|
||||||
|
set1 = filter filterRule set
|
||||||
|
hoc1 = foldl accumHOC hoc set1
|
||||||
|
|
||||||
|
filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args
|
||||||
|
filterRule (PCoerce fid) = isLive fid
|
||||||
|
filterRule _ = True
|
||||||
|
|
||||||
|
isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0
|
||||||
|
|
||||||
|
accumHOC hoc (PApply funid args) = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc fid -> IntSet.insert fid hoc) hoc (map snd hypos)) hoc args
|
||||||
|
accumHOC hoc _ = hoc
|
||||||
@@ -1,258 +0,0 @@
|
|||||||
{-# LANGUAGE BangPatterns #-}
|
|
||||||
module PGF.Optimize
|
|
||||||
( optimizePGF
|
|
||||||
, updateProductionIndices
|
|
||||||
) where
|
|
||||||
|
|
||||||
import PGF.CId
|
|
||||||
import PGF.Data
|
|
||||||
import PGF.Macros
|
|
||||||
--import Data.Maybe
|
|
||||||
import Data.List (mapAccumL)
|
|
||||||
import Data.Array.IArray
|
|
||||||
import Data.Array.MArray
|
|
||||||
import Data.Array.Unsafe as U(unsafeFreeze)
|
|
||||||
import Data.Array.ST
|
|
||||||
import Data.Array.Unboxed
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
import qualified Data.IntSet as IntSet
|
|
||||||
import qualified Data.IntMap as IntMap
|
|
||||||
import qualified PGF.TrieMap as TrieMap
|
|
||||||
import qualified Data.List as List
|
|
||||||
import Control.Monad.ST
|
|
||||||
|
|
||||||
optimizePGF :: PGF -> PGF
|
|
||||||
optimizePGF pgf = pgf{concretes=fmap (updateConcrete (abstract pgf) .
|
|
||||||
topDownFilter (lookStartCat pgf) .
|
|
||||||
bottomUpFilter ) (concretes pgf)}
|
|
||||||
|
|
||||||
updateProductionIndices :: PGF -> PGF
|
|
||||||
updateProductionIndices pgf = pgf{concretes = fmap (updateConcrete (abstract pgf)) (concretes pgf)}
|
|
||||||
|
|
||||||
topDownFilter :: CId -> Concr -> Concr
|
|
||||||
topDownFilter startCat cnc =
|
|
||||||
let env0 = (Map.empty,Map.empty)
|
|
||||||
(env1,defs) = IntMap.mapAccumWithKey (\env fid funids -> mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids)
|
|
||||||
env0
|
|
||||||
(lindefs cnc)
|
|
||||||
(env2,refs) = IntMap.mapAccumWithKey (\env fid funids -> mapAccumL (optimizeFun fidVar [PArg [] fid]) env funids)
|
|
||||||
env1
|
|
||||||
(linrefs cnc)
|
|
||||||
(env3,prods) = IntMap.mapAccumWithKey (\env fid set -> mapAccumLSet (optimizeProd fid) env set)
|
|
||||||
env2
|
|
||||||
(productions cnc)
|
|
||||||
cats = Map.mapWithKey filterCatLabels (cnccats cnc)
|
|
||||||
(seqs,funs) = env3
|
|
||||||
in cnc{ sequences = mkSetArray seqs
|
|
||||||
, cncfuns = mkSetArray funs
|
|
||||||
, productions = prods
|
|
||||||
, cnccats = cats
|
|
||||||
, lindefs = defs
|
|
||||||
, linrefs = refs
|
|
||||||
}
|
|
||||||
where
|
|
||||||
fid2cat fid =
|
|
||||||
case IntMap.lookup fid fid2catMap of
|
|
||||||
Just cat -> cat
|
|
||||||
Nothing -> case [fid | Just set <- [IntMap.lookup fid (productions cnc)], PCoerce fid <- Set.toList set] of
|
|
||||||
(fid:_) -> fid2cat fid
|
|
||||||
_ -> error "unknown forest id"
|
|
||||||
where
|
|
||||||
fid2catMap = IntMap.fromList ((fidVar,cidVar) : [(fid,cat) | (cat,CncCat start end lbls) <- Map.toList (cnccats cnc),
|
|
||||||
fid <- [start..end]])
|
|
||||||
|
|
||||||
starts =
|
|
||||||
case Map.lookup startCat (cnccats cnc) of
|
|
||||||
Just (CncCat _ _ lbls) -> [(startCat,lbl) | lbl <- indices lbls]
|
|
||||||
Nothing -> []
|
|
||||||
|
|
||||||
allRelations =
|
|
||||||
Map.unionsWith Set.union
|
|
||||||
[rel fid prod | (fid,set) <- IntMap.toList (productions cnc),
|
|
||||||
prod <- Set.toList set]
|
|
||||||
where
|
|
||||||
rel fid (PApply funid args) = Map.fromList [((fid2cat fid,lbl),deps args seqid) | (lbl,seqid) <- assocs lin]
|
|
||||||
where
|
|
||||||
CncFun _ lin = cncfuns cnc ! funid
|
|
||||||
rel fid _ = Map.empty
|
|
||||||
|
|
||||||
deps args seqid = Set.fromList [let PArg _ fid = args !! r in (fid2cat fid,d) | SymCat r d <- elems seq]
|
|
||||||
where
|
|
||||||
seq = sequences cnc ! seqid
|
|
||||||
|
|
||||||
-- here we create a mapping from a category to an array of indices.
|
|
||||||
-- An element of the array is equal to -1 if the corresponding index
|
|
||||||
-- is not going to be used in the optimized grammar, or the new index
|
|
||||||
-- if it will be used
|
|
||||||
closure :: Map.Map CId (UArray LIndex LIndex)
|
|
||||||
closure = runST $ do
|
|
||||||
set <- initSet
|
|
||||||
addLitCat cidString set
|
|
||||||
addLitCat cidInt set
|
|
||||||
addLitCat cidFloat set
|
|
||||||
addLitCat cidVar set
|
|
||||||
closureSet set starts
|
|
||||||
doneSet set
|
|
||||||
where
|
|
||||||
initSet :: ST s (Map.Map CId (STUArray s LIndex LIndex))
|
|
||||||
initSet =
|
|
||||||
fmap Map.fromAscList $ sequence
|
|
||||||
[fmap ((,) cat) (newArray (bounds lbls) (-1))
|
|
||||||
| (cat,CncCat _ _ lbls) <- Map.toAscList (cnccats cnc)]
|
|
||||||
|
|
||||||
addLitCat cat set =
|
|
||||||
case Map.lookup cat set of
|
|
||||||
Just indices -> writeArray indices 0 0
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
closureSet set [] = return ()
|
|
||||||
closureSet set (x@(cat,index):xs) =
|
|
||||||
case Map.lookup cat set of
|
|
||||||
Just indices -> do v <- readArray indices index
|
|
||||||
writeArray indices index 0
|
|
||||||
if v < 0
|
|
||||||
then case Map.lookup x allRelations of
|
|
||||||
Just ys -> closureSet set (Set.toList ys++xs)
|
|
||||||
Nothing -> closureSet set xs
|
|
||||||
else closureSet set xs
|
|
||||||
Nothing -> error "unknown cat"
|
|
||||||
|
|
||||||
doneSet set =
|
|
||||||
fmap Map.fromAscList $ mapM done (Map.toAscList set)
|
|
||||||
where
|
|
||||||
done (cat,indices) = do
|
|
||||||
(s,e) <- getBounds indices
|
|
||||||
reindex indices s e 0
|
|
||||||
indices <- U.unsafeFreeze indices
|
|
||||||
return (cat,indices)
|
|
||||||
|
|
||||||
reindex indices i j k
|
|
||||||
| i <= j = do v <- readArray indices i
|
|
||||||
if v < 0
|
|
||||||
then reindex indices (i+1) j k
|
|
||||||
else writeArray indices i k >>
|
|
||||||
reindex indices (i+1) j (k+1)
|
|
||||||
| otherwise = return ()
|
|
||||||
|
|
||||||
optimizeProd res env (PApply funid args) =
|
|
||||||
let (env',funid') = optimizeFun res args env funid
|
|
||||||
in (env', PApply funid' args)
|
|
||||||
optimizeProd res env prod = (env,prod)
|
|
||||||
|
|
||||||
optimizeFun res args (seqs,funs) funid =
|
|
||||||
let (seqs',lin') = mapAccumL addUnique seqs [amap updateSymbol (sequences cnc ! seqid) |
|
|
||||||
(lbl,seqid) <- assocs lin, indicesOf res ! lbl >= 0]
|
|
||||||
(funs',funid') = addUnique funs (CncFun fun (mkArray lin'))
|
|
||||||
in ((seqs',funs'), funid')
|
|
||||||
where
|
|
||||||
CncFun fun lin = cncfuns cnc ! funid
|
|
||||||
|
|
||||||
indicesOf fid
|
|
||||||
| fid < 0 = listArray (0,0) [0]
|
|
||||||
| otherwise =
|
|
||||||
case Map.lookup (fid2cat fid) closure of
|
|
||||||
Just indices -> indices
|
|
||||||
Nothing -> error "unknown category"
|
|
||||||
|
|
||||||
addUnique seqs seq =
|
|
||||||
case Map.lookup seq seqs of
|
|
||||||
Just seqid -> (seqs,seqid)
|
|
||||||
Nothing -> let seqid = Map.size seqs
|
|
||||||
in (Map.insert seq seqid seqs, seqid)
|
|
||||||
|
|
||||||
updateSymbol (SymCat r d) = let PArg _ fid = args !! r in SymCat r (indicesOf fid ! d)
|
|
||||||
updateSymbol s = s
|
|
||||||
|
|
||||||
filterCatLabels cat (CncCat start end lbls) =
|
|
||||||
case Map.lookup cat closure of
|
|
||||||
Just indices -> let lbls' = mkArray [lbl | (i,lbl) <- assocs lbls, indices ! i >= 0]
|
|
||||||
in CncCat start end lbls'
|
|
||||||
Nothing -> error "unknown category"
|
|
||||||
|
|
||||||
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
|
|
||||||
mkArray lst = listArray (0,length lst-1) lst
|
|
||||||
|
|
||||||
mapAccumLSet f b set = let (b',lst) = mapAccumL f b (Set.toList set)
|
|
||||||
in (b',Set.fromList lst)
|
|
||||||
|
|
||||||
|
|
||||||
bottomUpFilter :: Concr -> Concr
|
|
||||||
bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty IntSet.empty (productions cnc)}
|
|
||||||
|
|
||||||
filterProductions prods0 hoc0 prods
|
|
||||||
| prods0 == prods1 = prods0
|
|
||||||
| otherwise = filterProductions prods1 hoc1 prods
|
|
||||||
where
|
|
||||||
(prods1,hoc1) = IntMap.foldWithKey foldProdSet (IntMap.empty,IntSet.empty) prods
|
|
||||||
|
|
||||||
foldProdSet fid set (!prods,!hoc)
|
|
||||||
| Set.null set1 = (prods,hoc)
|
|
||||||
| otherwise = (IntMap.insert fid set1 prods,hoc1)
|
|
||||||
where
|
|
||||||
set1 = Set.filter filterRule set
|
|
||||||
hoc1 = Set.fold accumHOC hoc set1
|
|
||||||
|
|
||||||
filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args
|
|
||||||
filterRule (PCoerce fid) = isLive fid
|
|
||||||
filterRule _ = True
|
|
||||||
|
|
||||||
isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0
|
|
||||||
|
|
||||||
accumHOC (PApply funid args) hoc = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc (_,fid) -> IntSet.insert fid hoc) hoc hypos) hoc args
|
|
||||||
accumHOC _ hoc = hoc
|
|
||||||
|
|
||||||
splitLexicalRules cnc p_prods =
|
|
||||||
IntMap.foldWithKey split (IntMap.empty,IntMap.empty) p_prods
|
|
||||||
where
|
|
||||||
split fid set (lex,syn) =
|
|
||||||
let (lex0,syn0) = Set.partition isLexical set
|
|
||||||
!lex' = if Set.null lex0
|
|
||||||
then lex
|
|
||||||
else let !mp = IntMap.unionsWith (TrieMap.unionWith IntSet.union)
|
|
||||||
[words funid | PApply funid [] <- Set.toList lex0]
|
|
||||||
in IntMap.insert fid mp lex
|
|
||||||
!syn' = if Set.null syn0
|
|
||||||
then syn
|
|
||||||
else IntMap.insert fid syn0 syn
|
|
||||||
in (lex', syn')
|
|
||||||
|
|
||||||
|
|
||||||
isLexical (PApply _ []) = True
|
|
||||||
isLexical _ = False
|
|
||||||
|
|
||||||
words funid = IntMap.fromList [(lbl,seq2prefix (elems (sequences cnc ! seqid)))
|
|
||||||
| (lbl,seqid) <- assocs lins]
|
|
||||||
where
|
|
||||||
CncFun _ lins = cncfuns cnc ! funid
|
|
||||||
|
|
||||||
wf ts = (ts,IntSet.singleton funid)
|
|
||||||
|
|
||||||
seq2prefix [] = TrieMap.fromList [wf []]
|
|
||||||
seq2prefix (SymKS t :syms) = TrieMap.fromList [wf [t]]
|
|
||||||
seq2prefix (SymKP syms0 alts:syms) = TrieMap.unionsWith IntSet.union
|
|
||||||
(seq2prefix (syms0++syms) :
|
|
||||||
[seq2prefix (syms1 ++ syms) | (syms1,ps) <- alts])
|
|
||||||
seq2prefix (SymNE :syms) = TrieMap.empty
|
|
||||||
seq2prefix (SymBIND :syms) = TrieMap.fromList [wf ["&+"]]
|
|
||||||
seq2prefix (SymSOFT_BIND :syms) = TrieMap.fromList [wf []]
|
|
||||||
seq2prefix (SymSOFT_SPACE :syms) = TrieMap.fromList [wf []]
|
|
||||||
seq2prefix (SymCAPIT :syms) = TrieMap.fromList [wf ["&|"]]
|
|
||||||
seq2prefix (SymALL_CAPIT :syms) = TrieMap.fromList [wf ["&|"]]
|
|
||||||
|
|
||||||
updateConcrete abs cnc =
|
|
||||||
let p_prods0 = filterProductions IntMap.empty IntSet.empty (productions cnc)
|
|
||||||
(lex,p_prods) = splitLexicalRules cnc p_prods0
|
|
||||||
l_prods = linIndex cnc p_prods0
|
|
||||||
in cnc{pproductions = p_prods, lproductions = l_prods, lexicon = lex}
|
|
||||||
where
|
|
||||||
linIndex cnc productions =
|
|
||||||
Map.fromListWith (IntMap.unionWith Set.union)
|
|
||||||
[(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions
|
|
||||||
, prod <- Set.toList prods
|
|
||||||
, fun <- getFunctions prod]
|
|
||||||
where
|
|
||||||
getFunctions (PApply funid args) = let CncFun fun _ = cncfuns cnc ! funid in [fun]
|
|
||||||
getFunctions (PCoerce fid) = case IntMap.lookup fid productions of
|
|
||||||
Nothing -> []
|
|
||||||
Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod]
|
|
||||||
Reference in New Issue
Block a user