module GLL.Combinators.Visit.Sem where

import GLL.Combinators.Options
import GLL.Types.Grammar
import GLL.Types.Derivations

import Control.Monad (forM)
import qualified Data.Array as A
import qualified Data.IntMap as IM
import qualified Data.Set as S

type Sem_Symb t a = PCOptions -> Ancestors t 
                        -> SPPF t -> A.Array Int t -> Int -> Int -> IO [a]
type Sem_Alt  t a = PCOptions -> (Prod t,Int) -> Ancestors t 
                        -> SPPF t -> A.Array Int t -> Int -> Int -> IO [(Int,a)]

sem_nterm :: Bool -> Bool -> Nt -> [Prod t] -> [Sem_Alt t a] -> Sem_Symb t a
sem_nterm :: forall t a.
Bool -> Bool -> Nt -> [Prod t] -> [Sem_Alt t a] -> Sem_Symb t a
sem_nterm Bool
use_ctx Bool
left_biased Nt
x [Prod t]
alts [Sem_Alt t a]
ps PCOptions
opts Ancestors t
ctx SPPF t
sppf Array Int t
arr Int
l Int
r =
        let ctx' :: Ancestors t
ctx' = Ancestors t
ctx forall t. Ancestors t -> (Nt, Int, Int) -> Ancestors t
`toAncestors` (Nt
x,Int
l,Int
r)
            sems :: [(Prod t, Sem_Alt t a)]
sems = forall a b. [a] -> [b] -> [(a, b)]
zip [Prod t]
alts [Sem_Alt t a]
ps 
            seq :: (Prod t,
 PCOptions
 -> (Prod t, Int)
 -> Ancestors t
 -> SPPF t
 -> Array Int t
 -> Int
 -> Int
 -> t)
-> t
seq (alt :: Prod t
alt@(Prod Nt
_ Symbols t
rhs), PCOptions
-> (Prod t, Int)
-> Ancestors t
-> SPPF t
-> Array Int t
-> Int
-> Int
-> t
va3) = 
                PCOptions
-> (Prod t, Int)
-> Ancestors t
-> SPPF t
-> Array Int t
-> Int
-> Int
-> t
va3 PCOptions
opts (Prod t
alt,forall (t :: * -> *) a. Foldable t => t a -> Int
length Symbols t
rhs) forall {t}. Ancestors t
ctx' SPPF t
sppf Array Int t
arr Int
l Int
r 
        in if Bool
use_ctx Bool -> Bool -> Bool
&& Ancestors t
ctx forall t. Ancestors t -> (Symbol t, Int, Int) -> Bool
`inAncestors` (forall t. Nt -> Symbol t
Nt Nt
x, Int
l, Int
r) 
                then forall (m :: * -> *) a. Monad m => a -> m a
return []
                else do [[(Int, a)]]
ass <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Prod t, Sem_Alt t a)]
sems forall {t} {t} {t}.
(Prod t,
 PCOptions
 -> (Prod t, Int)
 -> Ancestors t
 -> SPPF t
 -> Array Int t
 -> Int
 -> Int
 -> t)
-> t
seq
                        let choices :: [[(Int, a)]]
choices = case (PCOptions -> Bool
pivot_select_nt PCOptions
opts, PCOptions -> Maybe (Int -> Int -> Ordering)
pivot_select PCOptions
opts) of
                                        (Bool
True,Just Int -> Int -> Ordering
compare) -> forall k a.
Eq k =>
(k -> k -> Ordering) -> [[(k, a)]] -> [[(k, a)]]
maintainWith Int -> Int -> Ordering
compare [[(Int, a)]]
ass
                                        (Bool, Maybe (Int -> Int -> Ordering))
_                   -> [[(Int, a)]]
ass
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Bool -> PCOptions -> [[a]] -> [a]
concatChoice Bool
left_biased PCOptions
opts (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) [[(Int, a)]]
choices))
 where
    concatChoice :: Bool -> PCOptions -> [[a]] -> [a]
    concatChoice :: forall a. Bool -> PCOptions -> [[a]] -> [a]
concatChoice Bool
left_biased PCOptions
opts [[a]]
ress = 
        if Bool
left_biased Bool -> Bool -> Bool
|| PCOptions -> Bool
left_biased_choice PCOptions
opts
        then forall {a}. [[a]] -> [a]
firstRes [[a]]
ress
        else forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
ress
     where  firstRes :: [[a]] -> [a]
firstRes []         = []
            firstRes ([]:[[a]]
ress)  = [[a]] -> [a]
firstRes [[a]]
ress
            firstRes ([a]
res:[[a]]
_)    = [a]
res

sem_apply :: Ord t => (a -> b) -> Sem_Symb t a -> Sem_Alt t b
sem_apply :: forall t a b. Ord t => (a -> b) -> Sem_Symb t a -> Sem_Alt t b
sem_apply a -> b
f Sem_Symb t a
p PCOptions
opts (Prod t
alt,Int
j) Ancestors t
ctx SPPF t
sppf Array Int t
arr Int
l Int
r = 
        let op :: (t -> b) -> t -> (Int, b)
op t -> b
f t
a = (Int
r,t -> b
f t
a)
        in do   [a]
as <- Sem_Symb t a
p PCOptions
opts Ancestors t
ctx SPPF t
sppf Array Int t
arr Int
l Int
r
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. a -> b -> a
const (forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {b}. (t -> b) -> t -> (Int, b)
op a -> b
f) [a]
as)) forall a b. (a -> b) -> a -> b
$ SPPF t
sppf forall t.
Ord t =>
SPPF t -> ((Prod t, Int), Int, Int) -> Maybe [Int]
`pNodeLookup` ((Prod t
alt,Int
1),Int
l,Int
r))

sem_seq :: Ord t => CombinatorOptions -> Sem_Alt t (a -> b) -> Sem_Symb t a -> Sem_Alt t b 
sem_seq :: forall t a b.
Ord t =>
CombinatorOptions
-> Sem_Alt t (a -> b) -> Sem_Symb t a -> Sem_Alt t b
sem_seq CombinatorOptions
local_opts Sem_Alt t (a -> b)
p Sem_Symb t a
q PCOptions
opts (alt :: Prod t
alt@(Prod Nt
x Symbols t
rhs),Int
j) Ancestors t
ctx SPPF t
sppf Array Int t
arr Int
l Int
r = 
    let ks :: [Int]
ks      = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ SPPF t
sppf forall t.
Ord t =>
SPPF t -> ((Prod t, Int), Int, Int) -> Maybe [Int]
`pNodeLookup` ((Prod t
alt,Int
j), Int
l, Int
r)
        choices :: [Int]
choices = case PCOptions -> Maybe (Int -> Int -> Ordering)
pivot_select (PCOptions -> CombinatorOptions -> PCOptions
runOptionsOn PCOptions
opts CombinatorOptions
local_opts) of
                    Maybe (Int -> Int -> Ordering)
Nothing      -> [Int]
ks
                    Just Int -> Int -> Ordering
compare -> forall a. (a -> a -> Ordering) -> [a] -> [a]
maximumsWith Int -> Int -> Ordering
compare [Int]
ks
        seq :: Int -> IO [(Int, b)]
seq Int
k  = do     [a]
as      <- Sem_Symb t a
q PCOptions
opts forall {t}. Ancestors t
ctx' SPPF t
sppf Array Int t
arr Int
k Int
r
                        [(Int, a -> b)]
a2bs    <- Sem_Alt t (a -> b)
p PCOptions
opts (Prod t
alt,Int
jforall a. Num a => a -> a -> a
-Int
1) forall {t}. Ancestors t
ctx'' SPPF t
sppf Array Int t
arr Int
l Int
k
                        forall (m :: * -> *) a. Monad m => a -> m a
return [ (Int
k,a -> b
a2b a
a) | (Int
_,a -> b
a2b) <- [(Int, a -> b)]
a2bs, a
a <- [a]
as ]
          where ctx' :: Ancestors t
ctx'  | Int
k forall a. Ord a => a -> a -> Bool
> Int
l       = forall {t}. Ancestors t
emptyAncestors 
                      | Bool
otherwise   = Ancestors t
ctx
                ctx'' :: Ancestors t
ctx'' | Int
k forall a. Ord a => a -> a -> Bool
< Int
r       = forall {t}. Ancestors t
emptyAncestors
                      | Bool
otherwise   = Ancestors t
ctx
    in do   [[(Int, b)]]
ass <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
choices Int -> IO [(Int, b)]
seq
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, b)]]
ass)

--- contexts
type Ancestors t = S.Set Nt

emptyAncestors :: Ancestors t
emptyAncestors :: forall {t}. Ancestors t
emptyAncestors = forall a. Set a
S.empty

inAncestors :: Ancestors t -> (Symbol t, Int, Int) -> Bool
inAncestors :: forall t. Ancestors t -> (Symbol t, Int, Int) -> Bool
inAncestors Ancestors t
ctx (Term t
_, Int
_, Int
_) = Bool
False
inAncestors Ancestors t
ctx (Nt Nt
x, Int
l, Int
r) = forall a. Ord a => a -> Set a -> Bool
S.member Nt
x Ancestors t
ctx 

toAncestors :: Ancestors t -> (Nt, Int, Int) -> Ancestors t
toAncestors :: forall t. Ancestors t -> (Nt, Int, Int) -> Ancestors t
toAncestors Ancestors t
ctx (Nt
x, Int
l, Int
r) = forall a. Ord a => a -> Set a -> Set a
S.insert Nt
x Ancestors t
ctx