{-# LANGUAGE BangPatterns, FlexibleContexts #-}
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
import Debug.Trace

optimizePGF :: PGF -> PGF
optimizePGF :: PGF -> PGF
optimizePGF PGF
pgf = PGF
pgf{concretes :: Map CId Concr
concretes=(Concr -> Concr) -> Map CId Concr -> Map CId Concr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Abstr -> Concr -> Concr
forall p. p -> Concr -> Concr
updateConcrete (PGF -> Abstr
abstract PGF
pgf) (Concr -> Concr) -> (Concr -> Concr) -> Concr -> Concr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
                                      CId -> Concr -> Concr
topDownFilter (PGF -> CId
lookStartCat PGF
pgf) (Concr -> Concr) -> (Concr -> Concr) -> Concr -> Concr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                      Concr -> Concr
bottomUpFilter                    ) (PGF -> Map CId Concr
concretes PGF
pgf)}

updateProductionIndices :: PGF -> PGF
updateProductionIndices :: PGF -> PGF
updateProductionIndices PGF
pgf = PGF
pgf{concretes :: Map CId Concr
concretes = (Concr -> Concr) -> Map CId Concr -> Map CId Concr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Abstr -> Concr -> Concr
forall p. p -> Concr -> Concr
updateConcrete (PGF -> Abstr
abstract PGF
pgf)) (PGF -> Map CId Concr
concretes PGF
pgf)}

topDownFilter :: CId -> Concr -> Concr
topDownFilter :: CId -> Concr -> Concr
topDownFilter CId
startCat Concr
cnc =
  let env0 :: (Map k a, Map k a)
env0         = (Map k a
forall k a. Map k a
Map.empty,Map k a
forall k a. Map k a
Map.empty)
      ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env1,IntMap [DotPos]
defs)  = ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
 -> DotPos
 -> [DotPos]
 -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
     [DotPos]))
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> IntMap [DotPos]
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
    IntMap [DotPos])
forall a b c.
(a -> DotPos -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c)
IntMap.mapAccumWithKey (\(Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env DotPos
fid [DotPos]
funids -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
 -> DotPos
 -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos), DotPos))
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> [DotPos]
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
    [DotPos])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (DotPos
-> [PArg]
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> DotPos
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos), DotPos)
optimizeFun DotPos
fid [[(DotPos, DotPos)] -> DotPos -> PArg
PArg [] DotPos
fidVar]) (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env [DotPos]
funids) 
                                            (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
forall k a k a. (Map k a, Map k a)
env0
                                            (Concr -> IntMap [DotPos]
lindefs Concr
cnc)
      ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env2,IntMap [DotPos]
refs)  = ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
 -> DotPos
 -> [DotPos]
 -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
     [DotPos]))
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> IntMap [DotPos]
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
    IntMap [DotPos])
forall a b c.
(a -> DotPos -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c)
IntMap.mapAccumWithKey (\(Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env DotPos
fid [DotPos]
funids -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
 -> DotPos
 -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos), DotPos))
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> [DotPos]
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
    [DotPos])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (DotPos
-> [PArg]
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> DotPos
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos), DotPos)
optimizeFun DotPos
fidVar [[(DotPos, DotPos)] -> DotPos -> PArg
PArg [] DotPos
fid]) (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env [DotPos]
funids)
                                            (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env1
                                            (Concr -> IntMap [DotPos]
linrefs Concr
cnc)
      ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env3,IntMap (Set Production)
prods) = ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
 -> DotPos
 -> Set Production
 -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
     Set Production))
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> IntMap (Set Production)
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
    IntMap (Set Production))
forall a b c.
(a -> DotPos -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c)
IntMap.mapAccumWithKey (\(Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env DotPos
fid Set Production
set  -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
 -> Production
 -> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
     Production))
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> Set Production
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
    Set Production)
forall a a b.
Ord a =>
(a -> b -> (a, a)) -> a -> Set b -> (a, Set a)
mapAccumLSet (DotPos
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> Production
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
    Production)
optimizeProd DotPos
fid) (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env Set Production
set)
                                            (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env2
                                            (Concr -> IntMap (Set Production)
productions Concr
cnc)
      cats :: Map CId CncCat
cats = (CId -> CncCat -> CncCat) -> Map CId CncCat -> Map CId CncCat
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey CId -> CncCat -> CncCat
filterCatLabels (Concr -> Map CId CncCat
cnccats Concr
cnc)
      (Array DotPos (Array DotPos Symbol)
seqs,Array DotPos CncFun
funs) = (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> (Array DotPos (Array DotPos Symbol), Array DotPos CncFun)
forall (a2 :: * -> * -> *) i2 (a :: * -> * -> *)
       (a :: * -> * -> *).
(IArray a2 Symbol, Ix i2, Ord (a2 i2 Symbol),
 IArray a (a2 i2 Symbol), IArray a CncFun) =>
(Map (a2 i2 Symbol) DotPos, Map CncFun DotPos)
-> (a DotPos (a2 i2 Symbol), a DotPos CncFun)
reorderSeqs (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env3
  in Concr
cnc{ sequences :: Array DotPos (Array DotPos Symbol)
sequences   = Array DotPos (Array DotPos Symbol)
seqs
        , cncfuns :: Array DotPos CncFun
cncfuns     = Array DotPos CncFun
funs
        , productions :: IntMap (Set Production)
productions = IntMap (Set Production)
prods
        , cnccats :: Map CId CncCat
cnccats     = Map CId CncCat
cats
        , lindefs :: IntMap [DotPos]
lindefs     = IntMap [DotPos]
defs
        , linrefs :: IntMap [DotPos]
linrefs     = IntMap [DotPos]
refs
        }
  where
    fid2cat :: DotPos -> CId
fid2cat DotPos
fid =
      case DotPos -> IntMap CId -> Maybe CId
forall a. DotPos -> IntMap a -> Maybe a
IntMap.lookup DotPos
fid IntMap CId
fid2catMap of
        Just CId
cat -> CId
cat
        Maybe CId
Nothing  -> case [DotPos
fid | Just Set Production
set <- [DotPos -> IntMap (Set Production) -> Maybe (Set Production)
forall a. DotPos -> IntMap a -> Maybe a
IntMap.lookup DotPos
fid (Concr -> IntMap (Set Production)
productions Concr
cnc)], PCoerce DotPos
fid <- Set Production -> [Production]
forall a. Set a -> [a]
Set.toList Set Production
set] of
                      (DotPos
fid:[DotPos]
_) -> DotPos -> CId
fid2cat DotPos
fid
                      [DotPos]
_       -> [Char] -> CId
forall a. HasCallStack => [Char] -> a
error [Char]
"unknown forest id"
      where
        fid2catMap :: IntMap CId
fid2catMap = [(DotPos, CId)] -> IntMap CId
forall a. [(DotPos, a)] -> IntMap a
IntMap.fromList ((DotPos
fidVar,CId
cidVar) (DotPos, CId) -> [(DotPos, CId)] -> [(DotPos, CId)]
forall a. a -> [a] -> [a]
:  [(DotPos
fid,CId
cat) | (CId
cat,CncCat DotPos
start DotPos
end Array DotPos [Char]
lbls) <- Map CId CncCat -> [(CId, CncCat)]
forall k a. Map k a -> [(k, a)]
Map.toList (Concr -> Map CId CncCat
cnccats Concr
cnc),
                                                                      DotPos
fid <- [DotPos
start..DotPos
end]])

    starts :: [(CId, DotPos)]
starts =
      case CId -> Map CId CncCat -> Maybe CncCat
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
startCat (Concr -> Map CId CncCat
cnccats Concr
cnc) of
        Just (CncCat DotPos
_ DotPos
_ Array DotPos [Char]
lbls) -> [(CId
startCat,DotPos
lbl) | DotPos
lbl <- Array DotPos [Char] -> [DotPos]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [i]
indices Array DotPos [Char]
lbls]
        Maybe CncCat
Nothing                -> []

    allRelations :: Map (CId, DotPos) (Set (CId, DotPos))
allRelations =
      (Set (CId, DotPos) -> Set (CId, DotPos) -> Set (CId, DotPos))
-> [Map (CId, DotPos) (Set (CId, DotPos))]
-> Map (CId, DotPos) (Set (CId, DotPos))
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set (CId, DotPos) -> Set (CId, DotPos) -> Set (CId, DotPos)
forall a. Ord a => Set a -> Set a -> Set a
Set.union
                     [DotPos -> Production -> Map (CId, DotPos) (Set (CId, DotPos))
rel DotPos
fid Production
prod | (DotPos
fid,Set Production
set) <- IntMap (Set Production) -> [(DotPos, Set Production)]
forall a. IntMap a -> [(DotPos, a)]
IntMap.toList (Concr -> IntMap (Set Production)
productions Concr
cnc),
                                     Production
prod <- Set Production -> [Production]
forall a. Set a -> [a]
Set.toList Set Production
set]
      where
        rel :: DotPos -> Production -> Map (CId, DotPos) (Set (CId, DotPos))
rel DotPos
fid (PApply DotPos
funid [PArg]
args) = [((CId, DotPos), Set (CId, DotPos))]
-> Map (CId, DotPos) (Set (CId, DotPos))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((DotPos -> CId
fid2cat DotPos
fid,DotPos
lbl),[PArg] -> DotPos -> Set (CId, DotPos)
deps [PArg]
args DotPos
seqid) | (DotPos
lbl,DotPos
seqid) <- UArray DotPos DotPos -> [(DotPos, DotPos)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs UArray DotPos DotPos
lin]
          where
            CncFun CId
_ UArray DotPos DotPos
lin = Concr -> Array DotPos CncFun
cncfuns Concr
cnc Array DotPos CncFun -> DotPos -> CncFun
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
funid
        rel DotPos
fid Production
_                   = Map (CId, DotPos) (Set (CId, DotPos))
forall k a. Map k a
Map.empty

        deps :: [PArg] -> DotPos -> Set (CId, DotPos)
deps [PArg]
args DotPos
seqid = [(CId, DotPos)] -> Set (CId, DotPos)
forall a. Ord a => [a] -> Set a
Set.fromList [let PArg [(DotPos, DotPos)]
_ DotPos
fid = [PArg]
args [PArg] -> DotPos -> PArg
forall a. [a] -> DotPos -> a
!! DotPos
r in (DotPos -> CId
fid2cat DotPos
fid,DotPos
d) | SymCat DotPos
r DotPos
d <- Array DotPos Symbol -> [Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems Array DotPos Symbol
seq]
          where
            seq :: Array DotPos Symbol
seq = Concr -> Array DotPos (Array DotPos Symbol)
sequences Concr
cnc Array DotPos (Array DotPos Symbol) -> DotPos -> Array DotPos Symbol
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
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 :: Map CId (UArray DotPos DotPos)
closure = (forall s. ST s (Map CId (UArray DotPos DotPos)))
-> Map CId (UArray DotPos DotPos)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Map CId (UArray DotPos DotPos)))
 -> Map CId (UArray DotPos DotPos))
-> (forall s. ST s (Map CId (UArray DotPos DotPos)))
-> Map CId (UArray DotPos DotPos)
forall a b. (a -> b) -> a -> b
$ do 
      Map CId (STUArray s DotPos DotPos)
set <- ST s (Map CId (STUArray s DotPos DotPos))
forall s. ST s (Map CId (STUArray s DotPos DotPos))
initSet
      CId -> Map CId (STUArray s DotPos DotPos) -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i k.
(MArray a e m, Ix i, Num i, Num e, Ord k) =>
k -> Map k (a i e) -> m ()
addLitCat CId
cidString Map CId (STUArray s DotPos DotPos)
set
      CId -> Map CId (STUArray s DotPos DotPos) -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i k.
(MArray a e m, Ix i, Num i, Num e, Ord k) =>
k -> Map k (a i e) -> m ()
addLitCat CId
cidInt    Map CId (STUArray s DotPos DotPos)
set
      CId -> Map CId (STUArray s DotPos DotPos) -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i k.
(MArray a e m, Ix i, Num i, Num e, Ord k) =>
k -> Map k (a i e) -> m ()
addLitCat CId
cidFloat  Map CId (STUArray s DotPos DotPos)
set
      CId -> Map CId (STUArray s DotPos DotPos) -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i k.
(MArray a e m, Ix i, Num i, Num e, Ord k) =>
k -> Map k (a i e) -> m ()
addLitCat CId
cidVar    Map CId (STUArray s DotPos DotPos)
set
      Map CId (STUArray s DotPos DotPos) -> [(CId, DotPos)] -> ST s ()
forall (m :: * -> *) (a :: * -> * -> *) a.
(MArray a a m, Num a, Ord a) =>
Map CId (a DotPos a) -> [(CId, DotPos)] -> m ()
closureSet Map CId (STUArray s DotPos DotPos)
set [(CId, DotPos)]
starts
      Map CId (STUArray s DotPos DotPos)
-> ST s (Map CId (UArray DotPos DotPos))
forall (f :: * -> *) (a :: * -> * -> *) e i (b :: * -> * -> *) k.
(MArray a e f, Ix i, Num e, Num i, IArray b e, Ord e, Eq k) =>
Map k (a i e) -> f (Map k (b i e))
doneSet Map CId (STUArray s DotPos DotPos)
set
      where
        initSet :: ST s (Map.Map CId (STUArray s LIndex LIndex))
        initSet :: ST s (Map CId (STUArray s DotPos DotPos))
initSet =
          ([(CId, STUArray s DotPos DotPos)]
 -> Map CId (STUArray s DotPos DotPos))
-> ST s [(CId, STUArray s DotPos DotPos)]
-> ST s (Map CId (STUArray s DotPos DotPos))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(CId, STUArray s DotPos DotPos)]
-> Map CId (STUArray s DotPos DotPos)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList (ST s [(CId, STUArray s DotPos DotPos)]
 -> ST s (Map CId (STUArray s DotPos DotPos)))
-> ST s [(CId, STUArray s DotPos DotPos)]
-> ST s (Map CId (STUArray s DotPos DotPos))
forall a b. (a -> b) -> a -> b
$ [ST s (CId, STUArray s DotPos DotPos)]
-> ST s [(CId, STUArray s DotPos DotPos)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                        [(STUArray s DotPos DotPos -> (CId, STUArray s DotPos DotPos))
-> ST s (STUArray s DotPos DotPos)
-> ST s (CId, STUArray s DotPos DotPos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) CId
cat) ((DotPos, DotPos) -> DotPos -> ST s (STUArray s DotPos DotPos)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Array DotPos [Char] -> (DotPos, DotPos)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array DotPos [Char]
lbls) (-DotPos
1))
                                             | (CId
cat,CncCat DotPos
_ DotPos
_ Array DotPos [Char]
lbls) <- Map CId CncCat -> [(CId, CncCat)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Concr -> Map CId CncCat
cnccats Concr
cnc)]

        addLitCat :: k -> Map k (a i e) -> m ()
addLitCat k
cat Map k (a i e)
set =
          case k -> Map k (a i e) -> Maybe (a i e)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
cat Map k (a i e)
set of
            Just a i e
indices -> a i e -> i -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a i e
indices i
0 e
0
            Maybe (a i e)
Nothing      -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        closureSet :: Map CId (a DotPos a) -> [(CId, DotPos)] -> m ()
closureSet Map CId (a DotPos a)
set []                 = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        closureSet Map CId (a DotPos a)
set (x :: (CId, DotPos)
x@(CId
cat,DotPos
index):[(CId, DotPos)]
xs) =
          case CId -> Map CId (a DotPos a) -> Maybe (a DotPos a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
cat Map CId (a DotPos a)
set of
            Just a DotPos a
indices -> do a
v <- a DotPos a -> DotPos -> m a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a DotPos a
indices DotPos
index
                               a DotPos a -> DotPos -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a DotPos a
indices DotPos
index a
0
                               if a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0
                                 then case (CId, DotPos)
-> Map (CId, DotPos) (Set (CId, DotPos))
-> Maybe (Set (CId, DotPos))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CId, DotPos)
x Map (CId, DotPos) (Set (CId, DotPos))
allRelations of
                                        Just Set (CId, DotPos)
ys -> Map CId (a DotPos a) -> [(CId, DotPos)] -> m ()
closureSet Map CId (a DotPos a)
set (Set (CId, DotPos) -> [(CId, DotPos)]
forall a. Set a -> [a]
Set.toList Set (CId, DotPos)
ys[(CId, DotPos)] -> [(CId, DotPos)] -> [(CId, DotPos)]
forall a. [a] -> [a] -> [a]
++[(CId, DotPos)]
xs)
                                        Maybe (Set (CId, DotPos))
Nothing -> Map CId (a DotPos a) -> [(CId, DotPos)] -> m ()
closureSet Map CId (a DotPos a)
set [(CId, DotPos)]
xs
                                 else Map CId (a DotPos a) -> [(CId, DotPos)] -> m ()
closureSet Map CId (a DotPos a)
set [(CId, DotPos)]
xs
            Maybe (a DotPos a)
Nothing      -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"unknown cat"

        doneSet :: Map k (a i e) -> f (Map k (b i e))
doneSet Map k (a i e)
set =
          ([(k, b i e)] -> Map k (b i e))
-> f [(k, b i e)] -> f (Map k (b i e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(k, b i e)] -> Map k (b i e)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList (f [(k, b i e)] -> f (Map k (b i e)))
-> f [(k, b i e)] -> f (Map k (b i e))
forall a b. (a -> b) -> a -> b
$ ((k, a i e) -> f (k, b i e)) -> [(k, a i e)] -> f [(k, b i e)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (k, a i e) -> f (k, b i e)
forall (m :: * -> *) (a :: * -> * -> *) e i (b :: * -> * -> *) a.
(MArray a e m, Ix i, Num e, Num i, IArray b e, Ord e) =>
(a, a i e) -> m (a, b i e)
done (Map k (a i e) -> [(k, a i e)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map k (a i e)
set)
          where
            done :: (a, a i e) -> m (a, b i e)
done (a
cat,a i e
indices) = do
              (i
s,i
e) <- a i e -> m (i, i)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds a i e
indices
              a i e -> i -> i -> e -> m ()
forall (m :: * -> *) (a :: * -> * -> *) a a.
(MArray a a m, Ix a, Ord a, Num a, Num a) =>
a a a -> a -> a -> a -> m ()
reindex a i e
indices i
s i
e e
0
              b i e
indices <- a i e -> m (b i e)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
U.unsafeFreeze a i e
indices
              (a, b i e) -> m (a, b i e)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
cat,b i e
indices)
              
            reindex :: a a a -> a -> a -> a -> m ()
reindex a a a
indices a
i a
j a
k
              | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
j    = do a
v <- a a a -> a -> m a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a a a
indices a
i
                               if a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0
                                 then a a a -> a -> a -> a -> m ()
reindex a a a
indices (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1) a
j a
k
                                 else a a a -> a -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a a a
indices a
i a
k m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                      a a a -> a -> a -> a -> m ()
reindex a a a
indices (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1) a
j (a
ka -> a -> a
forall a. Num a => a -> a -> a
+a
1)
              | Bool
otherwise = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    optimizeProd :: DotPos
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> Production
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos),
    Production)
optimizeProd DotPos
res (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env (PApply DotPos
funid [PArg]
args) =
      let ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env',DotPos
funid') = DotPos
-> [PArg]
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> DotPos
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos), DotPos)
optimizeFun DotPos
res [PArg]
args (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env DotPos
funid
      in ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env', DotPos -> [PArg] -> Production
PApply DotPos
funid' [PArg]
args)
    optimizeProd DotPos
res (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env Production
prod = ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
env,Production
prod)
    
    optimizeFun :: DotPos
-> [PArg]
-> (Map (Array DotPos Symbol) DotPos, Map CncFun DotPos)
-> DotPos
-> ((Map (Array DotPos Symbol) DotPos, Map CncFun DotPos), DotPos)
optimizeFun DotPos
res [PArg]
args (Map (Array DotPos Symbol) DotPos
seqs,Map CncFun DotPos
funs) DotPos
funid =
      let (Map (Array DotPos Symbol) DotPos
seqs',[DotPos]
lin') = (Map (Array DotPos Symbol) DotPos
 -> Array DotPos Symbol
 -> (Map (Array DotPos Symbol) DotPos, DotPos))
-> Map (Array DotPos Symbol) DotPos
-> [Array DotPos Symbol]
-> (Map (Array DotPos Symbol) DotPos, [DotPos])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Map (Array DotPos Symbol) DotPos
-> Array DotPos Symbol
-> (Map (Array DotPos Symbol) DotPos, DotPos)
forall k. Ord k => Map k DotPos -> k -> (Map k DotPos, DotPos)
addUnique Map (Array DotPos Symbol) DotPos
seqs [(Symbol -> Symbol) -> Array DotPos Symbol -> Array DotPos Symbol
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
amap Symbol -> Symbol
updateSymbol (Concr -> Array DotPos (Array DotPos Symbol)
sequences Concr
cnc Array DotPos (Array DotPos Symbol) -> DotPos -> Array DotPos Symbol
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
seqid) | 
                                                          (DotPos
lbl,DotPos
seqid) <- UArray DotPos DotPos -> [(DotPos, DotPos)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs UArray DotPos DotPos
lin, DotPos -> UArray DotPos DotPos
indicesOf DotPos
res UArray DotPos DotPos -> DotPos -> DotPos
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
lbl DotPos -> DotPos -> Bool
forall a. Ord a => a -> a -> Bool
>= DotPos
0]
          (Map CncFun DotPos
funs',DotPos
funid') = Map CncFun DotPos -> CncFun -> (Map CncFun DotPos, DotPos)
forall k. Ord k => Map k DotPos -> k -> (Map k DotPos, DotPos)
addUnique Map CncFun DotPos
funs (CId -> UArray DotPos DotPos -> CncFun
CncFun CId
fun ([DotPos] -> UArray DotPos DotPos
forall (a :: * -> * -> *) e. IArray a e => [e] -> a DotPos e
mkArray [DotPos]
lin'))
      in ((Map (Array DotPos Symbol) DotPos
seqs',Map CncFun DotPos
funs'), DotPos
funid')
      where
        CncFun CId
fun UArray DotPos DotPos
lin = Concr -> Array DotPos CncFun
cncfuns Concr
cnc Array DotPos CncFun -> DotPos -> CncFun
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
funid

        indicesOf :: DotPos -> UArray DotPos DotPos
indicesOf DotPos
fid
          | DotPos
fid DotPos -> DotPos -> Bool
forall a. Ord a => a -> a -> Bool
< DotPos
0   = (DotPos, DotPos) -> [DotPos] -> UArray DotPos DotPos
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (DotPos
0,DotPos
0) [DotPos
0]
          | Bool
otherwise =
              case CId
-> Map CId (UArray DotPos DotPos) -> Maybe (UArray DotPos DotPos)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (DotPos -> CId
fid2cat DotPos
fid) Map CId (UArray DotPos DotPos)
closure of
                Just UArray DotPos DotPos
indices -> UArray DotPos DotPos
indices
                Maybe (UArray DotPos DotPos)
Nothing      -> [Char] -> UArray DotPos DotPos
forall a. HasCallStack => [Char] -> a
error [Char]
"unknown category"

        addUnique :: Map k DotPos -> k -> (Map k DotPos, DotPos)
addUnique Map k DotPos
seqs k
seq =
          case k -> Map k DotPos -> Maybe DotPos
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
seq Map k DotPos
seqs of
            Just DotPos
seqid -> (Map k DotPos
seqs,DotPos
seqid)
            Maybe DotPos
Nothing    -> let seqid :: DotPos
seqid = Map k DotPos -> DotPos
forall k a. Map k a -> DotPos
Map.size Map k DotPos
seqs
                          in (k -> DotPos -> Map k DotPos -> Map k DotPos
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
seq DotPos
seqid Map k DotPos
seqs, DotPos
seqid)

        updateSymbol :: Symbol -> Symbol
updateSymbol (SymCat DotPos
r DotPos
d) = let PArg [(DotPos, DotPos)]
_ DotPos
fid = [PArg]
args [PArg] -> DotPos -> PArg
forall a. [a] -> DotPos -> a
!! DotPos
r in DotPos -> DotPos -> Symbol
SymCat DotPos
r (DotPos -> UArray DotPos DotPos
indicesOf DotPos
fid UArray DotPos DotPos -> DotPos -> DotPos
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
d)
        updateSymbol Symbol
s            = Symbol
s

    filterCatLabels :: CId -> CncCat -> CncCat
filterCatLabels CId
cat (CncCat DotPos
start DotPos
end Array DotPos [Char]
lbls) =
      case CId
-> Map CId (UArray DotPos DotPos) -> Maybe (UArray DotPos DotPos)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
cat Map CId (UArray DotPos DotPos)
closure of
        Just UArray DotPos DotPos
indices -> let lbls' :: Array DotPos [Char]
lbls' = [[Char]] -> Array DotPos [Char]
forall (a :: * -> * -> *) e. IArray a e => [e] -> a DotPos e
mkArray [[Char]
lbl | (DotPos
i,[Char]
lbl) <- Array DotPos [Char] -> [(DotPos, [Char])]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs Array DotPos [Char]
lbls, UArray DotPos DotPos
indices UArray DotPos DotPos -> DotPos -> DotPos
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
i DotPos -> DotPos -> Bool
forall a. Ord a => a -> a -> Bool
>= DotPos
0]
                        in DotPos -> DotPos -> Array DotPos [Char] -> CncCat
CncCat DotPos
start DotPos
end Array DotPos [Char]
lbls'
        Maybe (UArray DotPos DotPos)
Nothing      -> [Char] -> CncCat
forall a. HasCallStack => [Char] -> a
error [Char]
"unknown category"

    reorderSeqs :: (Map (a2 i2 Symbol) DotPos, Map CncFun DotPos)
-> (a DotPos (a2 i2 Symbol), a DotPos CncFun)
reorderSeqs (Map (a2 i2 Symbol) DotPos
seqs,Map CncFun DotPos
funs) = (a DotPos (a2 i2 Symbol)
seqs',a DotPos CncFun
funs')
      where
        sorted :: [(a2 i2 Symbol, DotPos)]
sorted = ((a2 i2 Symbol, DotPos) -> (a2 i2 Symbol, DotPos) -> Ordering)
-> [(a2 i2 Symbol, DotPos)] -> [(a2 i2 Symbol, DotPos)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortNubBy (a2 i2 Symbol, DotPos) -> (a2 i2 Symbol, DotPos) -> Ordering
forall (a2 :: * -> * -> *) i2 b b.
(IArray a2 Symbol, Ix i2, Ord (a2 i2 Symbol)) =>
(a2 i2 Symbol, b) -> (a2 i2 Symbol, b) -> Ordering
ciCmp (Map (a2 i2 Symbol) DotPos -> [(a2 i2 Symbol, DotPos)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (a2 i2 Symbol) DotPos
seqs)
        seqs' :: a DotPos (a2 i2 Symbol)
seqs'  = [a2 i2 Symbol] -> a DotPos (a2 i2 Symbol)
forall (a :: * -> * -> *) e. IArray a e => [e] -> a DotPos e
mkArray (((a2 i2 Symbol, DotPos) -> a2 i2 Symbol)
-> [(a2 i2 Symbol, DotPos)] -> [a2 i2 Symbol]
forall a b. (a -> b) -> [a] -> [b]
map (a2 i2 Symbol, DotPos) -> a2 i2 Symbol
forall a b. (a, b) -> a
fst [(a2 i2 Symbol, DotPos)]
sorted)
        re :: Array DotPos DotPos
re     = (DotPos, DotPos) -> [(DotPos, DotPos)] -> Array DotPos DotPos
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (DotPos
0,Map (a2 i2 Symbol) DotPos -> DotPos
forall k a. Map k a -> DotPos
Map.size Map (a2 i2 Symbol) DotPos
seqsDotPos -> DotPos -> DotPos
forall a. Num a => a -> a -> a
-DotPos
1) (((a2 i2 Symbol, DotPos) -> DotPos -> (DotPos, DotPos))
-> [(a2 i2 Symbol, DotPos)] -> [DotPos] -> [(DotPos, DotPos)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(a2 i2 Symbol
_,DotPos
i) DotPos
j -> (DotPos
i,DotPos
j)) [(a2 i2 Symbol, DotPos)]
sorted [DotPos
0..]) :: Array LIndex LIndex
        funs' :: a DotPos CncFun
funs'  = (DotPos, DotPos) -> [(DotPos, CncFun)] -> a DotPos CncFun
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (DotPos
0,Map CncFun DotPos -> DotPos
forall k a. Map k a -> DotPos
Map.size Map CncFun DotPos
funsDotPos -> DotPos -> DotPos
forall a. Num a => a -> a -> a
-DotPos
1) [(DotPos
v,CId -> UArray DotPos DotPos -> CncFun
CncFun CId
fun ((DotPos -> DotPos) -> UArray DotPos DotPos -> UArray DotPos DotPos
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
amap ((!) Array DotPos DotPos
re) UArray DotPos DotPos
lins)) | (CncFun CId
fun UArray DotPos DotPos
lins,DotPos
v) <- Map CncFun DotPos -> [(CncFun, DotPos)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CncFun DotPos
funs]

    ciCmp :: (a2 i2 Symbol, b) -> (a2 i2 Symbol, b) -> Ordering
ciCmp (a2 i2 Symbol
s1,b
_) (a2 i2 Symbol
s2,b
_)
      | CId -> Map CId Literal -> Maybe Literal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> CId
mkCId [Char]
"case_sensitive") (Concr -> Map CId Literal
cflags Concr
cnc) Maybe Literal -> Maybe Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal -> Maybe Literal
forall a. a -> Maybe a
Just ([Char] -> Literal
LStr [Char]
"on")
                   = a2 i2 Symbol -> a2 i2 Symbol -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a2 i2 Symbol
s1 a2 i2 Symbol
s2
      | Bool
otherwise  = a2 i2 Symbol -> a2 i2 Symbol -> Ordering
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) i1 i2.
(IArray a1 Symbol, IArray a2 Symbol, Ix i1, Ix i2) =>
a1 i1 Symbol -> a2 i2 Symbol -> Ordering
compareCaseInsensitve a2 i2 Symbol
s1 a2 i2 Symbol
s2

    mkArray :: [e] -> a DotPos e
mkArray [e]
lst = (DotPos, DotPos) -> [e] -> a DotPos e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (DotPos
0,[e] -> DotPos
forall (t :: * -> *) a. Foldable t => t a -> DotPos
length [e]
lstDotPos -> DotPos -> DotPos
forall a. Num a => a -> a -> a
-DotPos
1) [e]
lst
    
    mapAccumLSet :: (a -> b -> (a, a)) -> a -> Set b -> (a, Set a)
mapAccumLSet a -> b -> (a, a)
f a
b Set b
set = let (a
b',[a]
lst) = (a -> b -> (a, a)) -> a -> [b] -> (a, [a])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL a -> b -> (a, a)
f a
b (Set b -> [b]
forall a. Set a -> [a]
Set.toList Set b
set)
                           in (a
b',[a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
lst)


bottomUpFilter :: Concr -> Concr
bottomUpFilter :: Concr -> Concr
bottomUpFilter Concr
cnc = Concr
cnc{productions :: IntMap (Set Production)
productions=IntMap (Set Production)
-> IntMap (Set Production) -> IntMap (Set Production)
filterProductions IntMap (Set Production)
forall a. IntMap a
IntMap.empty (Concr -> IntMap (Set Production)
productions Concr
cnc)}

filterProductions :: IntMap (Set Production)
-> IntMap (Set Production) -> IntMap (Set Production)
filterProductions IntMap (Set Production)
prods0 IntMap (Set Production)
prods
  | IntMap (Set Production)
prods0 IntMap (Set Production) -> IntMap (Set Production) -> Bool
forall a. Eq a => a -> a -> Bool
== IntMap (Set Production)
prods1 = IntMap (Set Production)
prods0
  | Bool
otherwise        = IntMap (Set Production)
-> IntMap (Set Production) -> IntMap (Set Production)
filterProductions IntMap (Set Production)
prods1 IntMap (Set Production)
prods
  where
    prods1 :: IntMap (Set Production)
prods1 = (DotPos
 -> Set Production
 -> IntMap (Set Production)
 -> IntMap (Set Production))
-> IntMap (Set Production)
-> IntMap (Set Production)
-> IntMap (Set Production)
forall a b. (DotPos -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey DotPos
-> Set Production
-> IntMap (Set Production)
-> IntMap (Set Production)
foldProdSet IntMap (Set Production)
forall a. IntMap a
IntMap.empty IntMap (Set Production)
prods
    hoc :: IntSet
hoc    = (Set Production -> IntSet -> IntSet)
-> IntSet -> IntMap (Set Production) -> IntSet
forall a b. (a -> b -> b) -> b -> IntMap a -> b
IntMap.foldr (\Set Production
set !IntSet
hoc -> (Production -> IntSet -> IntSet)
-> IntSet -> Set Production -> IntSet
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Production -> IntSet -> IntSet
accumHOC IntSet
hoc Set Production
set) IntSet
IntSet.empty IntMap (Set Production)
prods

    foldProdSet :: DotPos
-> Set Production
-> IntMap (Set Production)
-> IntMap (Set Production)
foldProdSet DotPos
fid Set Production
set !IntMap (Set Production)
prods
      | Set Production -> Bool
forall a. Set a -> Bool
Set.null Set Production
set1 = IntMap (Set Production)
prods
      | Bool
otherwise     = DotPos
-> Set Production
-> IntMap (Set Production)
-> IntMap (Set Production)
forall a. DotPos -> a -> IntMap a -> IntMap a
IntMap.insert DotPos
fid Set Production
set1 IntMap (Set Production)
prods
      where
        set1 :: Set Production
set1 = (Production -> Bool) -> Set Production -> Set Production
forall a. (a -> Bool) -> Set a -> Set a
Set.filter Production -> Bool
filterRule Set Production
set

    filterRule :: Production -> Bool
filterRule (PApply DotPos
funid [PArg]
args) = (PArg -> Bool) -> [PArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(PArg [(DotPos, DotPos)]
_ DotPos
fid) -> DotPos -> Bool
isLive DotPos
fid) [PArg]
args
    filterRule (PCoerce DotPos
fid)       = DotPos -> Bool
isLive DotPos
fid
    filterRule Production
_                   = Bool
True

    isLive :: DotPos -> Bool
isLive DotPos
fid = DotPos -> Bool
isPredefFId DotPos
fid Bool -> Bool -> Bool
|| DotPos -> IntMap (Set Production) -> Bool
forall a. DotPos -> IntMap a -> Bool
IntMap.member DotPos
fid IntMap (Set Production)
prods0 Bool -> Bool -> Bool
|| DotPos -> IntSet -> Bool
IntSet.member DotPos
fid IntSet
hoc

    accumHOC :: Production -> IntSet -> IntSet
accumHOC (PApply DotPos
funid [PArg]
args) IntSet
hoc = (IntSet -> PArg -> IntSet) -> IntSet -> [PArg] -> IntSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\IntSet
hoc (PArg [(DotPos, DotPos)]
hypos DotPos
_) -> (IntSet -> (DotPos, DotPos) -> IntSet)
-> IntSet -> [(DotPos, DotPos)] -> IntSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\IntSet
hoc (DotPos
_,DotPos
fid) -> DotPos -> IntSet -> IntSet
IntSet.insert DotPos
fid IntSet
hoc) IntSet
hoc [(DotPos, DotPos)]
hypos) IntSet
hoc [PArg]
args
    accumHOC Production
_                   IntSet
hoc = IntSet
hoc

splitLexicalRules :: Concr
-> IntMap (Set Production)
-> (IntMap (IntMap (TrieMap [Char] IntSet)),
    IntMap (Set Production))
splitLexicalRules Concr
cnc IntMap (Set Production)
p_prods =
  (DotPos
 -> Set Production
 -> (IntMap (IntMap (TrieMap [Char] IntSet)),
     IntMap (Set Production))
 -> (IntMap (IntMap (TrieMap [Char] IntSet)),
     IntMap (Set Production)))
-> (IntMap (IntMap (TrieMap [Char] IntSet)),
    IntMap (Set Production))
-> IntMap (Set Production)
-> (IntMap (IntMap (TrieMap [Char] IntSet)),
    IntMap (Set Production))
forall a b. (DotPos -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey DotPos
-> Set Production
-> (IntMap (IntMap (TrieMap [Char] IntSet)),
    IntMap (Set Production))
-> (IntMap (IntMap (TrieMap [Char] IntSet)),
    IntMap (Set Production))
split (IntMap (IntMap (TrieMap [Char] IntSet))
forall a. IntMap a
IntMap.empty,IntMap (Set Production)
forall a. IntMap a
IntMap.empty) IntMap (Set Production)
p_prods
  where
    split :: DotPos
-> Set Production
-> (IntMap (IntMap (TrieMap [Char] IntSet)),
    IntMap (Set Production))
-> (IntMap (IntMap (TrieMap [Char] IntSet)),
    IntMap (Set Production))
split DotPos
fid Set Production
set (IntMap (IntMap (TrieMap [Char] IntSet))
lex,IntMap (Set Production)
syn) =
      let (Set Production
lex0,Set Production
syn0) = (Production -> Bool)
-> Set Production -> (Set Production, Set Production)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition Production -> Bool
isLexical Set Production
set
          !lex' :: IntMap (IntMap (TrieMap [Char] IntSet))
lex' = if Set Production -> Bool
forall a. Set a -> Bool
Set.null Set Production
lex0
                    then IntMap (IntMap (TrieMap [Char] IntSet))
lex
                    else let !mp :: IntMap (TrieMap [Char] IntSet)
mp = (TrieMap [Char] IntSet
 -> TrieMap [Char] IntSet -> TrieMap [Char] IntSet)
-> [IntMap (TrieMap [Char] IntSet)]
-> IntMap (TrieMap [Char] IntSet)
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IntMap.unionsWith ((IntSet -> IntSet -> IntSet)
-> TrieMap [Char] IntSet
-> TrieMap [Char] IntSet
-> TrieMap [Char] IntSet
forall k v.
Ord k =>
(v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v
TrieMap.unionWith IntSet -> IntSet -> IntSet
IntSet.union)
                                                     [DotPos -> IntMap (TrieMap [Char] IntSet)
words DotPos
funid | PApply DotPos
funid [] <- Set Production -> [Production]
forall a. Set a -> [a]
Set.toList Set Production
lex0]
                         in DotPos
-> IntMap (TrieMap [Char] IntSet)
-> IntMap (IntMap (TrieMap [Char] IntSet))
-> IntMap (IntMap (TrieMap [Char] IntSet))
forall a. DotPos -> a -> IntMap a -> IntMap a
IntMap.insert DotPos
fid IntMap (TrieMap [Char] IntSet)
mp IntMap (IntMap (TrieMap [Char] IntSet))
lex
          !syn' :: IntMap (Set Production)
syn' = if Set Production -> Bool
forall a. Set a -> Bool
Set.null Set Production
syn0
                    then IntMap (Set Production)
syn
                    else DotPos
-> Set Production
-> IntMap (Set Production)
-> IntMap (Set Production)
forall a. DotPos -> a -> IntMap a -> IntMap a
IntMap.insert DotPos
fid Set Production
syn0 IntMap (Set Production)
syn
      in (IntMap (IntMap (TrieMap [Char] IntSet))
lex', IntMap (Set Production)
syn')
      
    
    isLexical :: Production -> Bool
isLexical (PApply DotPos
_ []) = Bool
True
    isLexical Production
_             = Bool
False
    
    words :: DotPos -> IntMap (TrieMap [Char] IntSet)
words DotPos
funid = [(DotPos, TrieMap [Char] IntSet)] -> IntMap (TrieMap [Char] IntSet)
forall a. [(DotPos, a)] -> IntMap a
IntMap.fromList [(DotPos
lbl,[Symbol] -> TrieMap [Char] IntSet
seq2prefix (Array DotPos Symbol -> [Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems (Concr -> Array DotPos (Array DotPos Symbol)
sequences Concr
cnc Array DotPos (Array DotPos Symbol) -> DotPos -> Array DotPos Symbol
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
seqid)))
                                            | (DotPos
lbl,DotPos
seqid) <- UArray DotPos DotPos -> [(DotPos, DotPos)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs UArray DotPos DotPos
lins]
      where
        CncFun CId
_ UArray DotPos DotPos
lins = Concr -> Array DotPos CncFun
cncfuns Concr
cnc Array DotPos CncFun -> DotPos -> CncFun
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
funid
        
        wf :: a -> (a, IntSet)
wf a
ts = (a
ts,DotPos -> IntSet
IntSet.singleton DotPos
funid)
        
        seq2prefix :: [Symbol] -> TrieMap [Char] IntSet
seq2prefix []                      = [([[Char]], IntSet)] -> TrieMap [Char] IntSet
forall k v. Ord k => [([k], v)] -> TrieMap k v
TrieMap.fromList [[[Char]] -> ([[Char]], IntSet)
forall a. a -> (a, IntSet)
wf []]
        seq2prefix (SymKS [Char]
t         :[Symbol]
syms) = [([[Char]], IntSet)] -> TrieMap [Char] IntSet
forall k v. Ord k => [([k], v)] -> TrieMap k v
TrieMap.fromList [[[Char]] -> ([[Char]], IntSet)
forall a. a -> (a, IntSet)
wf [[Char]
t]]
        seq2prefix (SymKP [Symbol]
syms0 [([Symbol], [[Char]])]
alts:[Symbol]
syms) = (IntSet -> IntSet -> IntSet)
-> [TrieMap [Char] IntSet] -> TrieMap [Char] IntSet
forall k v. Ord k => (v -> v -> v) -> [TrieMap k v] -> TrieMap k v
TrieMap.unionsWith IntSet -> IntSet -> IntSet
IntSet.union
                                                ([Symbol] -> TrieMap [Char] IntSet
seq2prefix ([Symbol]
syms0[Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++[Symbol]
syms) TrieMap [Char] IntSet
-> [TrieMap [Char] IntSet] -> [TrieMap [Char] IntSet]
forall a. a -> [a] -> [a]
: 
                                                  [[Symbol] -> TrieMap [Char] IntSet
seq2prefix ([Symbol]
syms1 [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ [Symbol]
syms) | ([Symbol]
syms1,[[Char]]
ps) <- [([Symbol], [[Char]])]
alts])
        seq2prefix (Symbol
SymNE           :[Symbol]
syms) = TrieMap [Char] IntSet
forall k v. TrieMap k v
TrieMap.empty
        seq2prefix (Symbol
SymBIND         :[Symbol]
syms) = [([[Char]], IntSet)] -> TrieMap [Char] IntSet
forall k v. Ord k => [([k], v)] -> TrieMap k v
TrieMap.fromList [[[Char]] -> ([[Char]], IntSet)
forall a. a -> (a, IntSet)
wf [[Char]
"&+"]]
        seq2prefix (Symbol
SymSOFT_BIND    :[Symbol]
syms) = [([[Char]], IntSet)] -> TrieMap [Char] IntSet
forall k v. Ord k => [([k], v)] -> TrieMap k v
TrieMap.fromList [[[Char]] -> ([[Char]], IntSet)
forall a. a -> (a, IntSet)
wf []]
        seq2prefix (Symbol
SymSOFT_SPACE   :[Symbol]
syms) = [([[Char]], IntSet)] -> TrieMap [Char] IntSet
forall k v. Ord k => [([k], v)] -> TrieMap k v
TrieMap.fromList [[[Char]] -> ([[Char]], IntSet)
forall a. a -> (a, IntSet)
wf []]
        seq2prefix (Symbol
SymCAPIT        :[Symbol]
syms) = [([[Char]], IntSet)] -> TrieMap [Char] IntSet
forall k v. Ord k => [([k], v)] -> TrieMap k v
TrieMap.fromList [[[Char]] -> ([[Char]], IntSet)
forall a. a -> (a, IntSet)
wf [[Char]
"&|"]]
        seq2prefix (Symbol
SymALL_CAPIT    :[Symbol]
syms) = [([[Char]], IntSet)] -> TrieMap [Char] IntSet
forall k v. Ord k => [([k], v)] -> TrieMap k v
TrieMap.fromList [[[Char]] -> ([[Char]], IntSet)
forall a. a -> (a, IntSet)
wf [[Char]
"&|"]]

updateConcrete :: p -> Concr -> Concr
updateConcrete p
abs Concr
cnc = 
  let p_prods0 :: IntMap (Set Production)
p_prods0      = IntMap (Set Production)
-> IntMap (Set Production) -> IntMap (Set Production)
filterProductions IntMap (Set Production)
forall a. IntMap a
IntMap.empty (Concr -> IntMap (Set Production)
productions Concr
cnc)
      (IntMap (IntMap (TrieMap [Char] IntSet))
lex,IntMap (Set Production)
p_prods) = Concr
-> IntMap (Set Production)
-> (IntMap (IntMap (TrieMap [Char] IntSet)),
    IntMap (Set Production))
splitLexicalRules Concr
cnc IntMap (Set Production)
p_prods0
      l_prods :: Map CId (IntMap (Set Production))
l_prods       = Concr
-> IntMap (Set Production) -> Map CId (IntMap (Set Production))
linIndex Concr
cnc IntMap (Set Production)
p_prods0
  in Concr
cnc{pproductions :: IntMap (Set Production)
pproductions = IntMap (Set Production)
p_prods, lproductions :: Map CId (IntMap (Set Production))
lproductions = Map CId (IntMap (Set Production))
l_prods, lexicon :: IntMap (IntMap (TrieMap [Char] IntSet))
lexicon = IntMap (IntMap (TrieMap [Char] IntSet))
lex}
  where
    linIndex :: Concr
-> IntMap (Set Production) -> Map CId (IntMap (Set Production))
linIndex Concr
cnc IntMap (Set Production)
productions = 
      (IntMap (Set Production)
 -> IntMap (Set Production) -> IntMap (Set Production))
-> [(CId, IntMap (Set Production))]
-> Map CId (IntMap (Set Production))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ((Set Production -> Set Production -> Set Production)
-> IntMap (Set Production)
-> IntMap (Set Production)
-> IntMap (Set Production)
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith Set Production -> Set Production -> Set Production
forall a. Ord a => Set a -> Set a -> Set a
Set.union)
                       [(CId
fun,DotPos -> Set Production -> IntMap (Set Production)
forall a. DotPos -> a -> IntMap a
IntMap.singleton DotPos
res (Production -> Set Production
forall a. a -> Set a
Set.singleton Production
prod)) | (DotPos
res,Set Production
prods) <- IntMap (Set Production) -> [(DotPos, Set Production)]
forall a. IntMap a -> [(DotPos, a)]
IntMap.toList IntMap (Set Production)
productions
                                                                        , Production
prod <- Set Production -> [Production]
forall a. Set a -> [a]
Set.toList Set Production
prods
                                                                        , CId
fun <- Production -> [CId]
getFunctions Production
prod]
      where
        getFunctions :: Production -> [CId]
getFunctions (PApply DotPos
funid [PArg]
args) = let CncFun CId
fun UArray DotPos DotPos
_ = Concr -> Array DotPos CncFun
cncfuns Concr
cnc Array DotPos CncFun -> DotPos -> CncFun
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! DotPos
funid in [CId
fun]
        getFunctions (PCoerce DotPos
fid)       = case DotPos -> IntMap (Set Production) -> Maybe (Set Production)
forall a. DotPos -> IntMap a -> Maybe a
IntMap.lookup DotPos
fid IntMap (Set Production)
productions of
                                             Maybe (Set Production)
Nothing    -> []
                                             Just Set Production
prods -> [CId
fun | Production
prod <- Set Production -> [Production]
forall a. Set a -> [a]
Set.toList Set Production
prods, CId
fun <- Production -> [CId]
getFunctions Production
prod]