{-# LANGUAGE StandaloneDeriving #-}

module GLL.Types.Derivations where

import qualified    Data.Map as M
import qualified    Data.IntMap as IM
import qualified    Data.Set as S 
import qualified    Data.IntSet as IS 
import              Data.List (elemIndices, findIndices)
import GLL.Types.Grammar

-- make sure that tokens are equal independent of their character level value
type SlotL t    = (Slot t, Int)                   -- slot with left extent
type PrL t      = (Prod t, Int)                     -- Production rule with left extent
type NtL        = (Nt, Int)                     -- Nonterminal with left extent

-- SPPF

-- | 
-- An 'SPPF' contains symbol nodes, intermediate nodes, packed nodes and edges between them.
-- See Scott and Johnstone (2013) for an explanation of the 'SPPF'.
type SPPF t     =   (SymbMap t, ImdMap t, PackMap t, EdgeMap t)

-- | 
-- Stores packed nodes using nested "Data.IntMap"s, nesting is as follows:
--
-- * left extent
-- * right extent
-- * dot position (from left to right)
-- * mapping from productions to set of pivots
type PackMap t  =   IM.IntMap (IM.IntMap (IM.IntMap (M.Map (Prod t) IS.IntSet)))

-- | 
-- Stores symbol nodes using nested "Data.IntMap"s, nesting is as follows:
--
-- * left extent
-- * right extent
-- * set of symbols
type SymbMap t  =   IM.IntMap (IM.IntMap (S.Set (Symbol t)))

-- | 
-- Stores intermediate nodes using nested "Data.IntMap"s, nesting is as follows:
--
-- * left extent
-- * right extent
-- * set of slots 
type ImdMap t   =   IM.IntMap (IM.IntMap (S.Set (Slot t)))

-- | 
-- Stores edges, potentially costly.
type EdgeMap t  =   M.Map (SPPFNode t) (S.Set (SPPFNode t))

-- | 
-- An "SPPFNode" is either a symbol node, an intermediate node, a packed node or a dummy.
data SPPFNode t =   SNode (Symbol t, Int, Int) 
                |   INode (Slot t, Int, Int)
                |   PNode (Slot t, Int, Int, Int)
                |   Dummy
    deriving (SPPFNode t -> SPPFNode t -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {t}. Ord t => Eq (SPPFNode t)
forall t. Ord t => SPPFNode t -> SPPFNode t -> Bool
forall t. Ord t => SPPFNode t -> SPPFNode t -> Ordering
forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPFNode t
min :: SPPFNode t -> SPPFNode t -> SPPFNode t
$cmin :: forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPFNode t
max :: SPPFNode t -> SPPFNode t -> SPPFNode t
$cmax :: forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPFNode t
>= :: SPPFNode t -> SPPFNode t -> Bool
$c>= :: forall t. Ord t => SPPFNode t -> SPPFNode t -> Bool
> :: SPPFNode t -> SPPFNode t -> Bool
$c> :: forall t. Ord t => SPPFNode t -> SPPFNode t -> Bool
<= :: SPPFNode t -> SPPFNode t -> Bool
$c<= :: forall t. Ord t => SPPFNode t -> SPPFNode t -> Bool
< :: SPPFNode t -> SPPFNode t -> Bool
$c< :: forall t. Ord t => SPPFNode t -> SPPFNode t -> Bool
compare :: SPPFNode t -> SPPFNode t -> Ordering
$ccompare :: forall t. Ord t => SPPFNode t -> SPPFNode t -> Ordering
Ord, SPPFNode t -> SPPFNode t -> Bool
forall t. Eq t => SPPFNode t -> SPPFNode t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SPPFNode t -> SPPFNode t -> Bool
$c/= :: forall t. Eq t => SPPFNode t -> SPPFNode t -> Bool
== :: SPPFNode t -> SPPFNode t -> Bool
$c== :: forall t. Eq t => SPPFNode t -> SPPFNode t -> Bool
Eq)

type SNode t    = (Symbol t, Int, Int)
type PNode t    = (Prod t, [Int])
type SEdge t    = M.Map (SNode t)(S.Set (PNode t))
type PEdge t    = M.Map (PNode t) (S.Set (SNode t))

emptySPPF :: (Ord t) => SPPF t
emptySPPF :: forall t. Ord t => SPPF t
emptySPPF = (forall a. IntMap a
IM.empty, forall a. IntMap a
IM.empty, forall a. IntMap a
IM.empty, forall k a. Map k a
M.empty)

pNodeLookup :: (Ord t) => SPPF t -> ((Prod t, Int), Int, Int) -> Maybe [Int]
pNodeLookup :: forall t.
Ord t =>
SPPF t -> ((Prod t, Int), Int, Int) -> Maybe [Int]
pNodeLookup (SymbMap t
_,ImdMap t
_,PackMap t
pMap,EdgeMap t
_) ((Prod t
alt,Int
j),Int
l,Int
r) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing IntMap (IntMap (Map (Prod t) IntSet)) -> Maybe [Int]
inner forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l PackMap t
pMap
    where   inner :: IntMap (IntMap (Map (Prod t) IntSet)) -> Maybe [Int]
inner   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing IntMap (Map (Prod t) IntSet) -> Maybe [Int]
inner2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
r
            inner2 :: IntMap (Map (Prod t) IntSet) -> Maybe [Int]
inner2  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing Map (Prod t) IntSet -> Maybe [Int]
inner3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
j
            inner3 :: Map (Prod t) IntSet -> Maybe [Int]
inner3  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Prod t
alt

pMapInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
pMapInsert :: forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
pMapInsert SPPFNode t
f SPPFNode t
t (SymbMap t
sMap,ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap) =  
    let pMap' :: PackMap t
pMap' = case SPPFNode t
f of 
                    PNode ((Slot Nt
x [Symbol t]
alpha [Symbol t]
beta), Int
l, Int
k, Int
r) ->   
                        Prod t -> Int -> Int -> Int -> Int -> PackMap t
add (forall t. Nt -> Symbols t -> Prod t
Prod Nt
x ([Symbol t]
alphaforall a. [a] -> [a] -> [a]
++[Symbol t]
beta)) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol t]
alpha) Int
l Int
r Int
k
                    SPPFNode t
_   -> PackMap t
pMap
    in (SymbMap t
sMap,ImdMap t
iMap,PackMap t
pMap',EdgeMap t
eMap)
 where add :: Prod t -> Int -> Int -> Int -> Int -> PackMap t
add Prod t
alt Int
j Int
l Int
r Int
k = forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
-> Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
addInnerL Int
l PackMap t
pMap
        where addInnerL :: Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
-> Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
addInnerL Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
mm = case Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
mm of 
                             Maybe (IntMap (IntMap (Map (Prod t) IntSet)))
Nothing -> forall a. a -> Maybe a
Just IntMap (IntMap (Map (Prod t) IntSet))
singleRJAK
                             Just IntMap (IntMap (Map (Prod t) IntSet))
m ->  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap (Map (Prod t) IntSet))
-> Maybe (IntMap (Map (Prod t) IntSet))
addInnerR Int
r IntMap (IntMap (Map (Prod t) IntSet))
m
              addInnerR :: Maybe (IntMap (Map (Prod t) IntSet))
-> Maybe (IntMap (Map (Prod t) IntSet))
addInnerR Maybe (IntMap (Map (Prod t) IntSet))
mm = case Maybe (IntMap (Map (Prod t) IntSet))
mm of
                             Maybe (IntMap (Map (Prod t) IntSet))
Nothing -> forall a. a -> Maybe a
Just IntMap (Map (Prod t) IntSet)
singleJAK
                             Just IntMap (Map (Prod t) IntSet)
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (Map (Prod t) IntSet) -> Maybe (Map (Prod t) IntSet)
addInnerJ Int
j IntMap (Map (Prod t) IntSet)
m
              addInnerJ :: Maybe (Map (Prod t) IntSet) -> Maybe (Map (Prod t) IntSet)
addInnerJ Maybe (Map (Prod t) IntSet)
mm = case Maybe (Map (Prod t) IntSet)
mm of
                             Maybe (Map (Prod t) IntSet)
Nothing -> forall a. a -> Maybe a
Just Map (Prod t) IntSet
singleAK
                             Just Map (Prod t) IntSet
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith IntSet -> IntSet -> IntSet
IS.union Prod t
alt IntSet
singleK Map (Prod t) IntSet
m
              singleRJAK :: IntMap (IntMap (Map (Prod t) IntSet))
singleRJAK= forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
r, IntMap (Map (Prod t) IntSet)
singleJAK)]
              singleJAK :: IntMap (Map (Prod t) IntSet)
singleJAK = forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
j, Map (Prod t) IntSet
singleAK)]
              singleAK :: Map (Prod t) IntSet
singleAK  = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Prod t
alt, IntSet
singleK)]
              singleK :: IntSet
singleK   = Int -> IntSet
IS.singleton Int
k


sNodeLookup :: (Ord t) => SPPF t -> (Symbol t, Int, Int) -> Bool 
sNodeLookup :: forall t. Ord t => SPPF t -> (Symbol t, Int, Int) -> Bool
sNodeLookup (SymbMap t
sm,ImdMap t
_,PackMap t
_,EdgeMap t
_) (Symbol t
s,Int
l,Int
r) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False IntMap (Set (Symbol t)) -> Bool
inner forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l SymbMap t
sm
    where   inner :: IntMap (Set (Symbol t)) -> Bool
inner   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
S.member Symbol t
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
r

sNodeInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
sNodeInsert :: forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
sNodeInsert SPPFNode t
f SPPFNode t
t (SymbMap t
sMap,ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap) = 
    let sMap' :: SymbMap t
sMap' = case SPPFNode t
f of
                SNode (Symbol t
s, Int
l, Int
r) -> SymbMap t -> SymbMap t
newt (forall {p}.
Ord p =>
p
-> Int -> Int -> IntMap (IntMap (Set p)) -> IntMap (IntMap (Set p))
add Symbol t
s Int
l Int
r SymbMap t
sMap)
                SPPFNode t
_               -> SymbMap t -> SymbMap t
newt SymbMap t
sMap
    in (SymbMap t
sMap',ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap)
 where newt :: SymbMap t -> SymbMap t
newt SymbMap t
sMap = case SPPFNode t
t of 
                   (SNode (Symbol t
s, Int
l, Int
r)) -> forall {p}.
Ord p =>
p
-> Int -> Int -> IntMap (IntMap (Set p)) -> IntMap (IntMap (Set p))
add Symbol t
s Int
l Int
r SymbMap t
sMap
                   SPPFNode t
_                 -> SymbMap t
sMap
       add :: p
-> Int -> Int -> IntMap (IntMap (Set p)) -> IntMap (IntMap (Set p))
add p
s Int
l Int
r IntMap (IntMap (Set p))
sMap = forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap (Set p)) -> Maybe (IntMap (Set p))
addInnerL Int
l IntMap (IntMap (Set p))
sMap
        where addInnerL :: Maybe (IntMap (Set p)) -> Maybe (IntMap (Set p))
addInnerL Maybe (IntMap (Set p))
mm = case Maybe (IntMap (Set p))
mm of 
                             Maybe (IntMap (Set p))
Nothing -> forall a. a -> Maybe a
Just IntMap (Set p)
singleRS
                             Just IntMap (Set p)
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith (forall a. Ord a => Set a -> Set a -> Set a
S.union) Int
r Set p
singleS IntMap (Set p)
m
              singleRS :: IntMap (Set p)
singleRS     = forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
r, Set p
singleS)]
              singleS :: Set p
singleS      = forall a. a -> Set a
S.singleton p
s
 
sNodeRemove :: (Ord t) => SPPF t -> (Symbol t, Int, Int) -> SPPF t
sNodeRemove :: forall t. Ord t => SPPF t -> (Symbol t, Int, Int) -> SPPF t
sNodeRemove (SymbMap t
sm,ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap) (Symbol t
s,Int
l,Int
r) = 
    (forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust IntMap (Set (Symbol t)) -> IntMap (Set (Symbol t))
inner Int
l SymbMap t
sm, ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap)
    where   inner :: IntMap (Set (Symbol t)) -> IntMap (Set (Symbol t))
inner   = forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust ((Symbol t
s forall a. Ord a => a -> Set a -> Set a
`S.delete`)) Int
r

iNodeLookup :: (Ord t) => SPPF t -> (Slot t, Int, Int) -> Bool 
iNodeLookup :: forall t. Ord t => SPPF t -> (Slot t, Int, Int) -> Bool
iNodeLookup (SymbMap t
_,ImdMap t
iMap,PackMap t
_,EdgeMap t
_) (Slot t
s,Int
l,Int
r) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False IntMap (Set (Slot t)) -> Bool
inner forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l ImdMap t
iMap
    where   inner :: IntMap (Set (Slot t)) -> Bool
inner   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
S.member Slot t
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
r

iNodeInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
iNodeInsert :: forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
iNodeInsert SPPFNode t
f SPPFNode t
t (SymbMap t
sMap,ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap) = 
    let iMap' :: ImdMap t
iMap' = case SPPFNode t
f of
                INode (Slot t
s, Int
l, Int
r) -> ImdMap t -> ImdMap t
newt (forall {p}.
Ord p =>
p
-> Int -> Int -> IntMap (IntMap (Set p)) -> IntMap (IntMap (Set p))
add Slot t
s Int
l Int
r ImdMap t
iMap)
                SPPFNode t
_               -> ImdMap t -> ImdMap t
newt ImdMap t
iMap
    in (SymbMap t
sMap,ImdMap t
iMap',PackMap t
pMap,EdgeMap t
eMap)
 where newt :: ImdMap t -> ImdMap t
newt ImdMap t
iMap = case SPPFNode t
t of 
                   (INode (Slot t
s, Int
l, Int
r)) -> forall {p}.
Ord p =>
p
-> Int -> Int -> IntMap (IntMap (Set p)) -> IntMap (IntMap (Set p))
add Slot t
s Int
l Int
r ImdMap t
iMap
                   SPPFNode t
_                 -> ImdMap t
iMap
       add :: p
-> Int -> Int -> IntMap (IntMap (Set p)) -> IntMap (IntMap (Set p))
add p
s Int
l Int
r IntMap (IntMap (Set p))
iMap = forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap (Set p)) -> Maybe (IntMap (Set p))
addInnerL Int
l IntMap (IntMap (Set p))
iMap
        where addInnerL :: Maybe (IntMap (Set p)) -> Maybe (IntMap (Set p))
addInnerL Maybe (IntMap (Set p))
mm = case Maybe (IntMap (Set p))
mm of 
                             Maybe (IntMap (Set p))
Nothing -> forall a. a -> Maybe a
Just IntMap (Set p)
singleRS
                             Just IntMap (Set p)
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith (forall a. Ord a => Set a -> Set a -> Set a
S.union) Int
r Set p
singleS IntMap (Set p)
m
              singleRS :: IntMap (Set p)
singleRS     = forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
r, Set p
singleS)]
              singleS :: Set p
singleS      = forall a. a -> Set a
S.singleton p
s
 
iNodeRemove :: (Ord t) => SPPF t -> (Slot t, Int, Int) -> SPPF t
iNodeRemove :: forall t. Ord t => SPPF t -> (Slot t, Int, Int) -> SPPF t
iNodeRemove (SymbMap t
sMap,ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap) (Slot t
s,Int
l,Int
r) = 
    (SymbMap t
sMap,forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust IntMap (Set (Slot t)) -> IntMap (Set (Slot t))
inner Int
l ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap)
    where   inner :: IntMap (Set (Slot t)) -> IntMap (Set (Slot t))
inner   = forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust ((Slot t
s forall a. Ord a => a -> Set a -> Set a
`S.delete`)) Int
r

eMapInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
eMapInsert :: forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
eMapInsert SPPFNode t
f SPPFNode t
t (SymbMap t
sMap,ImdMap t
iMap,PackMap t
pMap,EdgeMap t
eMap) =  
    (SymbMap t
sMap,ImdMap t
iMap,PackMap t
pMap,forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (forall a. Ord a => Set a -> Set a -> Set a
S.union) SPPFNode t
f (forall a. a -> Set a
S.singleton SPPFNode t
t) EdgeMap t
eMap)

-- helpers for Ucal
inU :: (a, Int, Int) -> IntMap (IntMap (Set a)) -> Bool
inU (a
slot,Int
l,Int
i) IntMap (IntMap (Set a))
u = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False IntMap (Set a) -> Bool
inner forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l IntMap (IntMap (Set a))
u
         where inner :: IntMap (Set a) -> Bool
inner = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
S.member a
slot) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i

toU :: (a, Int, Int) -> IntMap (IntMap (Set a)) -> IntMap (IntMap (Set a))
toU (a
slot,Int
l,Int
i) IntMap (IntMap (Set a))
u = forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap (Set a)) -> Maybe (IntMap (Set a))
inner Int
l IntMap (IntMap (Set a))
u
 where inner :: Maybe (IntMap (Set a)) -> Maybe (IntMap (Set a))
inner Maybe (IntMap (Set a))
mm = case Maybe (IntMap (Set a))
mm of
                Maybe (IntMap (Set a))
Nothing -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ IntMap (Set a)
singleIS
                Just IntMap (Set a)
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith forall a. Ord a => Set a -> Set a -> Set a
S.union Int
i Set a
singleS IntMap (Set a)
m
       singleIS :: IntMap (Set a)
singleIS = forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
i,Set a
singleS)]
       singleS :: Set a
singleS  = forall a. a -> Set a
S.singleton a
slot


showD :: Map a [a] -> String
showD Map a [a]
dv = [String] -> String
unlines [ forall a. Show a => a -> String
show a
f forall a. [a] -> [a] -> [a]
++ String
" --> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
t | (a
f,[a]
ts) <- forall k a. Map k a -> [(k, a)]
M.toList Map a [a]
dv, a
t <- [a]
ts ]
showG :: Map a [a] -> String
showG Map a [a]
dv = [String] -> String
unlines [ forall a. Show a => a -> String
show a
f forall a. [a] -> [a] -> [a]
++ String
" --> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
t | (a
f,[a]
ts) <- forall k a. Map k a -> [(k, a)]
M.toList Map a [a]
dv, a
t <- [a]
ts ]
showP :: IntMap (IntMap (IntMap (Map a a))) -> String
showP IntMap (IntMap (IntMap (Map a a)))
pMap = [String] -> String
unlines [ forall a. Show a => a -> String
show ((a
a,Int
j),Int
l,Int
r) forall a. [a] -> [a] -> [a]
++ String
" --> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
kset
                            | (Int
l,IntMap (IntMap (Map a a))
r2j) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap (IntMap (Map a a)))
pMap, (Int
r,IntMap (Map a a)
j2a) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap (Map a a))
r2j
                            , (Int
j,Map a a
a2k) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Map a a)
j2a, (a
a,a
kset) <- forall k a. Map k a -> [(k, a)]
M.assocs Map a a
a2k ]
showS :: IntMap (IntMap a) -> String
showS IntMap (IntMap a)
sMap = [String] -> String
unlines [ forall a. Show a => a -> String
show (Int
l,Int
r) forall a. [a] -> [a] -> [a]
++ String
" --> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (a
sset)
                            | (Int
l,IntMap a
r2s) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap a)
sMap, (Int
r,a
sset) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap a
r2s]

showSPPF :: Show t => SPPF t -> String 
showSPPF :: forall t. Show t => SPPF t -> String
showSPPF (SymbMap t
_,ImdMap t
_,PackMap t
pMap,EdgeMap t
_) = forall {a} {a}.
(Show a, Show a) =>
IntMap (IntMap (IntMap (Map a a))) -> String
showP PackMap t
pMap 

type ProdMap t   = M.Map Nt [Prod t]
type PrefixMap t = M.Map (Prod t,Int) ([t], Maybe Nt)
type SelectMap t = M.Map (Nt, [Symbol t]) (S.Set t)
type FirstMap  t = M.Map Nt (S.Set t)
type FollowMap t = M.Map Nt (S.Set t)

fixedMaps :: (Eq t, Ord t, Parseable t) => Nt -> [Prod t] -> 
                (ProdMap t, PrefixMap t, FirstMap t, FollowMap t, SelectMap t) 
fixedMaps :: forall t.
(Eq t, Ord t, Parseable t) =>
Nt
-> [Prod t]
-> (ProdMap t, PrefixMap t, FirstMap t, FirstMap t, SelectMap t)
fixedMaps Nt
s [Prod t]
prs = (Map Nt [Prod t]
prodMap, Map (Prod t, Int) ([t], Maybe Nt)
prefixMap, Map Nt (Set t)
firstMap, Map Nt (Set t)
followMap, Map (Nt, [Symbol t]) (Set t)
selectMap)
 where
    prodMap :: Map Nt [Prod t]
prodMap = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++) [ (Nt
x,[Prod t
pr]) | pr :: Prod t
pr@(Prod Nt
x [Symbol t]
_) <- [Prod t]
prs ]

    prefixMap :: Map (Prod t, Int) ([t], Maybe Nt)
prefixMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList 
        [ ((Prod t
pr,Int
j), ([t]
tokens,Maybe Nt
msymb)) | pr :: Prod t
pr@(Prod Nt
x [Symbol t]
alpha) <- [Prod t]
prs
                                   , (Int
j,[t]
tokens,Maybe Nt
msymb) <- forall {p} {b}. p -> [Symbol b] -> [(Int, [b], Maybe Nt)]
prefix Nt
x [Symbol t]
alpha ]
     where
        prefix :: p -> [Symbol b] -> [(Int, [b], Maybe Nt)]
prefix p
x [Symbol b]
alpha = forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> (Int, [b], Maybe Nt)
rangePrefix [(Int, Int)]
ranges
         where  js :: [Int]
js          = (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
(+) Int
1) (forall a. (a -> Bool) -> [a] -> [Int]
findIndices forall {t}. Symbol t -> Bool
isNt [Symbol b]
alpha))
                ranges :: [(Int, Int)]
ranges      = forall a b. [a] -> [b] -> [(a, b)]
zip (Int
0forall a. a -> [a] -> [a]
:[Int]
js) ([Int]
js forall a. [a] -> [a] -> [a]
++ [forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol b]
alpha])
                rangePrefix :: (Int, Int) -> (Int, [b], Maybe Nt)
rangePrefix (Int
a,Int
z) | Int
a forall a. Ord a => a -> a -> Bool
>= Int
z = (Int
a,[],forall a. Maybe a
Nothing)
                rangePrefix (Int
a,Int
z) = 
                    let init :: [b]
init = forall a b. (a -> b) -> [a] -> [b]
map ((\(Term b
t) -> b
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Symbol b]
alpha forall a. [a] -> Int -> a
!!)) [Int
a .. (Int
zforall a. Num a => a -> a -> a
-Int
2)]
                        last :: Symbol b
last = [Symbol b]
alpha forall a. [a] -> Int -> a
!! (Int
zforall a. Num a => a -> a -> a
-Int
1)
                     in case Symbol b
last of    
                           Nt Nt
nt     -> (Int
a,[b]
init, forall a. a -> Maybe a
Just Nt
nt)
                           Term b
t    -> (Int
a,[b]
init forall a. [a] -> [a] -> [a]
++ [b
t], forall a. Maybe a
Nothing)

    firstMap :: Map Nt (Set t)
firstMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Nt
x, [Nt] -> Nt -> Set t
first_x [] Nt
x) | Nt
x <- forall k a. Map k a -> [k]
M.keys Map Nt [Prod t]
prodMap ]

    first_x :: [Nt] -> Nt -> Set t
first_x [Nt]
ys Nt
x           = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [ [Nt] -> [Symbol t] -> Set t
first_alpha (Nt
xforall a. a -> [a] -> [a]
:[Nt]
ys) [Symbol t]
rhs | Prod Nt
_ [Symbol t]
rhs <- Map Nt [Prod t]
prodMap forall k a. Ord k => Map k a -> k -> a
M.! Nt
x ]
 
    selectMap :: Map (Nt, [Symbol t]) (Set t)
selectMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ ((Nt
x,[Symbol t]
alpha), [Symbol t] -> Nt -> Set t
select [Symbol t]
alpha Nt
x) | Prod Nt
x [Symbol t]
rhs <- [Prod t]
prs
                           , [Symbol t]
alpha <- forall {t}. [Symbol t] -> [[Symbol t]]
split [Symbol t]
rhs ]
     where
        split :: [Symbol t] -> [[Symbol t]]
split [Symbol t]
rhs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> [[Symbol t]] -> [[Symbol t]]
op [] [Int]
js
         where op :: Int -> [[Symbol t]] -> [[Symbol t]]
op Int
j [[Symbol t]]
acc     = forall a. Int -> [a] -> [a]
drop Int
j [Symbol t]
rhs forall a. a -> [a] -> [a]
: [[Symbol t]]
acc
               js :: [Int]
js           = Int
0 forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [Int]
findIndices forall {t}. Symbol t -> Bool
isNt [Symbol t]
rhs

        -- TODO store intermediate results
        select :: [Symbol t] -> Nt -> Set t
select [Symbol t]
alpha Nt
x      = Set t
res 
                where   firsts :: Set t
firsts  = [Nt] -> [Symbol t] -> Set t
first_alpha [] [Symbol t]
alpha
                        res :: Set t
res     | forall a. Parseable a => a
eps forall a. Ord a => a -> Set a -> Bool
`S.member` Set t
firsts     = forall a. Ord a => a -> Set a -> Set a
S.delete forall a. Parseable a => a
eps Set t
firsts forall a. Ord a => Set a -> Set a -> Set a
`S.union` (Map Nt (Set t)
followMap forall k a. Ord k => Map k a -> k -> a
M.! Nt
x)
                                | Bool
otherwise                 = Set t
firsts

    -- list of symbols to get firsts from + non-terminal to ignore
    -- TODO store in map
    first_alpha :: [Nt] -> [Symbol t] -> Set t
first_alpha [Nt]
ys []      = forall a. a -> Set a
S.singleton forall a. Parseable a => a
eps 
    first_alpha [Nt]
ys (Symbol t
x:[Symbol t]
xs)  =  
        case Symbol t
x of
          Term t
tau        -> if t
tau forall a. Eq a => a -> a -> Bool
== forall a. Parseable a => a
eps then [Nt] -> [Symbol t] -> Set t
first_alpha [Nt]
ys [Symbol t]
xs
                                           else forall a. a -> Set a
S.singleton t
tau
          Nt Nt
x            ->  
            let fs :: Set t
fs | Nt
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Nt]
ys       = forall a. Set a
S.empty 
                   | Bool
otherwise        = [Nt] -> Nt -> Set t
first_x (Nt
xforall a. a -> [a] -> [a]
:[Nt]
ys) Nt
x
              in  if Nt
x forall a. Ord a => a -> Set a -> Bool
`S.member` Set Nt
nullableSet
                        then forall a. Ord a => a -> Set a -> Set a
S.delete forall a. Parseable a => a
eps Set t
fs forall a. Ord a => Set a -> Set a -> Set a
`S.union` [Nt] -> [Symbol t] -> Set t
first_alpha (Nt
xforall a. a -> [a] -> [a]
:[Nt]
ys) [Symbol t]
xs
                        else Set t
fs

    followMap :: Map Nt (Set t)
followMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Nt
x, [Nt] -> Nt -> Set t
follow [] Nt
x) | Nt
x <- forall k a. Map k a -> [k]
M.keys Map Nt [Prod t]
prodMap ] 
 
    follow :: [Nt] -> Nt -> Set t
follow [Nt]
ys Nt
x = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a b. (a -> b) -> [a] -> [b]
map (Nt, [Symbol t]) -> Set t
fw (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Nt
x Map Nt [(Nt, [Symbol t])]
localMap))
                            forall a. Ord a => Set a -> Set a -> Set a
`S.union` (if Nt
x forall a. Eq a => a -> a -> Bool
== Nt
s then forall a. a -> Set a
S.singleton forall a. Parseable a => a
eos else forall a. Set a
S.empty)
             where fw :: (Nt, [Symbol t]) -> Set t
fw (Nt
y,[Symbol t]
ss) = 
                        let ts :: Set t
ts  = forall a. Ord a => a -> Set a -> Set a
S.delete forall a. Parseable a => a
eps ([Nt] -> [Symbol t] -> Set t
first_alpha [] [Symbol t]
ss)
                            fs :: Set t
fs  = [Nt] -> Nt -> Set t
follow (Nt
xforall a. a -> [a] -> [a]
:[Nt]
ys) Nt
y 
                         in if forall t. [Nt] -> [Symbol t] -> Bool
nullable_alpha [] [Symbol t]
ss Bool -> Bool -> Bool
&& Bool -> Bool
not (Nt
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Nt
yforall a. a -> [a] -> [a]
:[Nt]
ys))
                               then Set t
ts forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set t
fs 
                               else Set t
ts

    localMap :: Map Nt [(Nt, [Symbol t])]
localMap = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++)
                [ (Nt
x,[(Nt
y,[Symbol t]
tail)]) | Nt
x <- forall k a. Map k a -> [k]
M.keys Map Nt [Prod t]
prodMap, (Prod Nt
y [Symbol t]
rhs) <- [Prod t]
prs
                                 , [Symbol t]
tail <- forall {t}. Eq t => Nt -> [Symbol t] -> [[Symbol t]]
tails Nt
x [Symbol t]
rhs ]
     where
        tails :: Nt -> [Symbol t] -> [[Symbol t]]
tails Nt
x [Symbol t]
symbs = [ forall a. Int -> [a] -> [a]
drop (Int
index forall a. Num a => a -> a -> a
+ Int
1) [Symbol t]
symbs | Int
index <- [Int]
indices ]
         where indices :: [Int]
indices = forall a. Eq a => a -> [a] -> [Int]
elemIndices (forall t. Nt -> Symbol t
Nt Nt
x) [Symbol t]
symbs
                     
    nullableSet :: S.Set Nt
    nullableSet :: Set Nt
nullableSet  = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ [ Nt
x | Nt
x <- forall k a. Map k a -> [k]
M.keys Map Nt [Prod t]
prodMap, [Nt] -> Nt -> Bool
nullable_x [] Nt
x ]

    -- a nonterminal is nullable if any of its alternatives is empty 
    nullable_x :: [Nt] -> Nt -> Bool
    nullable_x :: [Nt] -> Nt -> Bool
nullable_x [Nt]
ys Nt
x      = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ forall t. [Nt] -> [Symbol t] -> Bool
nullable_alpha (Nt
xforall a. a -> [a] -> [a]
:[Nt]
ys) [Symbol t]
rhs 
                              | (Prod Nt
_ [Symbol t]
rhs) <- Map Nt [Prod t]
prodMap forall k a. Ord k => Map k a -> k -> a
M.! Nt
x ] 

    -- TODO store in map
    nullable_alpha :: [Nt] -> [Symbol t] -> Bool
    nullable_alpha :: forall t. [Nt] -> [Symbol t] -> Bool
nullable_alpha [Nt]
ys [] = Bool
True
    nullable_alpha [Nt]
ys (Symbol t
s:[Symbol t]
ss) =     
        case Symbol t
s of
            Nt Nt
nt      -> if Nt
nt forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Nt]
ys 
                            then Bool
False --nullable only if some other alternative is nullable
                            else [Nt] -> Nt -> Bool
nullable_x [Nt]
ys Nt
nt Bool -> Bool -> Bool
&& forall t. [Nt] -> [Symbol t] -> Bool
nullable_alpha (Nt
ntforall a. a -> [a] -> [a]
:[Nt]
ys) [Symbol t]
ss
            Symbol t
otherwise  -> Bool
False

{-
instance Show Symbol where
    show (Nt nt) = "Nt " ++ show nt
    show (Term t) = "Term " ++ show t
    show (Error t1 t2) = "Error " ++ show t1 ++ " " ++ show t2

instance Eq Symbol where
    (Nt nt) == (Nt nt') = nt == nt'
    (Term t) == (Term t') = t == t'
    (Error t1 t2) == (Error t1' t2') = (t1,t2) == (t1',t2')

instance Ord Symbol where
    (Nt nt) `compare` (Nt nt') = nt `compare` nt
    (Nt _)  `compare`  _       = LT
    _  `compare`  (Nt _)       = GT
    (Term t) `compare` (Term t') = t `compare` t'
    (Term _) `compare` _         = LT
    _        `compare` (Term _)   = GT
    (Error t1 t2) `compare` (Error t1' t2') = (t1,t2) `compare` (t1',t2')
-}