> module Happy.Tabular (
>     Tables(..),
>     genTables,
>     SelectReductions,
>     select_all_reductions,
>     select_first_reduction
>   ) where

> import Happy.Grammar
> import Happy.Tabular.First
> import Happy.Tabular.LALR
> import Happy.Tabular.NameSet (NameSet)

> import Data.Array( Array, assocs, elems, (!) )
> import Data.List ( nub )

> data Tables =
>   Tables {
>     Tables -> [ItemSetWithGotos]
lr0items         :: [ItemSetWithGotos],
>     Tables -> [(Int, Lr0Item, NameSet)]
la_spont         :: [(Int, Lr0Item, NameSet)],
>     Tables -> Array Int [(Lr0Item, Int, Lr0Item)]
la_prop          :: Array Int [(Lr0Item, Int, Lr0Item)],
>     Tables -> Array Int [(Lr0Item, NameSet)]
lookaheads       :: Array Int [(Lr0Item, NameSet)],
>     Tables -> [([Lr1Item], [(Int, Int)])]
lr1items         :: [ ([Lr1Item], [(Name,Int)]) ],
>     Tables -> GotoTable
gotoTable        :: GotoTable,
>     Tables -> ActionTable
actionTable      :: ActionTable,
>     Tables -> (Array Int (Int, Int), (Int, Int))
conflicts        :: (Array Int (Int,Int), (Int,Int)),
>     Tables -> ([Int], [String])
redundancies     :: ([Int], [String])
>   }

> genTables ::
>     SelectReductions ->     -- for computing used/unused
>     Grammar ->
>     Tables
> genTables :: SelectReductions -> Grammar -> Tables
genTables SelectReductions
select_reductions Grammar
g =
>       let first :: [Int] -> NameSet
first       = {-# SCC "First" #-} (Grammar -> [Int] -> NameSet
mkFirst Grammar
g)
>           closures :: Int -> RuleList
closures    = {-# SCC "Closures" #-} (Grammar -> Int -> RuleList
precalcClosure0 Grammar
g)
>           lr0items :: [ItemSetWithGotos]
lr0items    = {-# SCC "LR0_Sets" #-} (Grammar -> (Int -> RuleList) -> [ItemSetWithGotos]
genLR0items Grammar
g Int -> RuleList
closures)
>           ([(Int, Lr0Item, NameSet)]
la_spont, Array Int [(Lr0Item, Int, Lr0Item)]
la_prop)
>                       = {-# SCC "Prop" #-} (Grammar
-> [ItemSetWithGotos]
-> ([Int] -> NameSet)
-> ([(Int, Lr0Item, NameSet)], Array Int [(Lr0Item, Int, Lr0Item)])
propLookaheads Grammar
g [ItemSetWithGotos]
lr0items [Int] -> NameSet
first)
>           lookaheads :: Array Int [(Lr0Item, NameSet)]
lookaheads  = {-# SCC "Calc" #-} (Int
-> [(Int, Lr0Item, NameSet)]
-> Array Int [(Lr0Item, Int, Lr0Item)]
-> Array Int [(Lr0Item, NameSet)]
calcLookaheads ([ItemSetWithGotos] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ItemSetWithGotos]
lr0items) [(Int, Lr0Item, NameSet)]
la_spont Array Int [(Lr0Item, Int, Lr0Item)]
la_prop)
>           lr1items :: [([Lr1Item], [(Int, Int)])]
lr1items    = {-# SCC "Merge" #-} (Array Int [(Lr0Item, NameSet)]
-> [ItemSetWithGotos] -> [([Lr1Item], [(Int, Int)])]
mergeLookaheadInfo Array Int [(Lr0Item, NameSet)]
lookaheads [ItemSetWithGotos]
lr0items)
>           gotoTable :: GotoTable
gotoTable   = {-# SCC "Goto" #-} (Grammar -> [ItemSetWithGotos] -> GotoTable
genGotoTable Grammar
g [ItemSetWithGotos]
lr0items)
>           actionTable :: ActionTable
actionTable = {-# SCC "Action" #-} (Grammar
-> ([Int] -> NameSet) -> [([Lr1Item], [(Int, Int)])] -> ActionTable
genActionTable Grammar
g [Int] -> NameSet
first [([Lr1Item], [(Int, Int)])]
lr1items)
>           conflicts :: (Array Int (Int, Int), (Int, Int))
conflicts   = {-# SCC "Conflict" #-} (ActionTable -> (Array Int (Int, Int), (Int, Int))
countConflicts ActionTable
actionTable)
>           redundancies :: ([Int], [String])
redundancies = SelectReductions -> Grammar -> ActionTable -> ([Int], [String])
find_redundancies SelectReductions
select_reductions Grammar
g ActionTable
actionTable
>       in Tables { [ItemSetWithGotos]
lr0items :: [ItemSetWithGotos]
lr0items :: [ItemSetWithGotos]
lr0items, [(Int, Lr0Item, NameSet)]
la_spont :: [(Int, Lr0Item, NameSet)]
la_spont :: [(Int, Lr0Item, NameSet)]
la_spont, Array Int [(Lr0Item, Int, Lr0Item)]
la_prop :: Array Int [(Lr0Item, Int, Lr0Item)]
la_prop :: Array Int [(Lr0Item, Int, Lr0Item)]
la_prop, Array Int [(Lr0Item, NameSet)]
lookaheads :: Array Int [(Lr0Item, NameSet)]
lookaheads :: Array Int [(Lr0Item, NameSet)]
lookaheads, [([Lr1Item], [(Int, Int)])]
lr1items :: [([Lr1Item], [(Int, Int)])]
lr1items :: [([Lr1Item], [(Int, Int)])]
lr1items,
>                   GotoTable
gotoTable :: GotoTable
gotoTable :: GotoTable
gotoTable, ActionTable
actionTable :: ActionTable
actionTable :: ActionTable
actionTable, (Array Int (Int, Int), (Int, Int))
conflicts :: (Array Int (Int, Int), (Int, Int))
conflicts :: (Array Int (Int, Int), (Int, Int))
conflicts, ([Int], [String])
redundancies :: ([Int], [String])
redundancies :: ([Int], [String])
redundancies }

-----------------------------------------------------------------------------
Find unused rules and tokens

> find_redundancies
>        :: SelectReductions -> Grammar -> ActionTable -> ([Int], [String])
> find_redundancies :: SelectReductions -> Grammar -> ActionTable -> ([Int], [String])
find_redundancies SelectReductions
extract_reductions Grammar
g ActionTable
action_table =
>       ([Int]
unused_rules, (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Array Int String
env Array Int String -> Int -> String
forall i e. Ix i => Array i e -> i -> e
!) [Int]
unused_terminals)
>    where
>       Grammar { terminals :: Grammar -> [Int]
terminals = [Int]
terms,
>                 token_names :: Grammar -> Array Int String
token_names = Array Int String
env,
>                 eof_term :: Grammar -> Int
eof_term = Int
eof,
>                 starts :: Grammar -> [(String, Int, Int, Bool)]
starts = [(String, Int, Int, Bool)]
starts',
>                 productions :: Grammar -> [Production]
productions = [Production]
productions'
>               } = Grammar
g
>       actions :: [(Int, LRAction)]
actions          = [[(Int, LRAction)]] -> [(Int, LRAction)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Array Int LRAction -> [(Int, LRAction)])
-> [Array Int LRAction] -> [[(Int, LRAction)]]
forall a b. (a -> b) -> [a] -> [b]
map Array Int LRAction -> [(Int, LRAction)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs (ActionTable -> [Array Int LRAction]
forall i e. Array i e -> [e]
elems ActionTable
action_table))
>       start_rules :: [Int]
start_rules      = [ Int
0 .. ([(String, Int, Int, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Int, Int, Bool)]
starts' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ]
>       used_rules :: [Int]
used_rules       = [Int]
start_rules [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
>                          [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [ Int
r | (Int
_,LRAction
a) <- [(Int, LRAction)]
actions, Int
r <- SelectReductions
extract_reductions LRAction
a ]
>       used_tokens :: [Int]
used_tokens      = Int
errorTok Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int
eof Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:
>                              [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [ Int
t | (Int
t,LRAction
a) <- [(Int, LRAction)]
actions, LRAction -> Bool
is_shift LRAction
a ]
>       n_prods :: Int
n_prods          = [Production] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Production]
productions'
>       unused_terminals :: [Int]
unused_terminals = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
used_tokens) [Int]
terms
>       unused_rules :: [Int]
unused_rules     = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
used_rules ) [Int
0..Int
n_prodsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

> is_shift :: LRAction -> Bool
> is_shift :: LRAction -> Bool
is_shift (LR'Shift Int
_ Priority
_)             = Bool
True
> is_shift (LR'Multiple [LRAction]
_ LR'Shift{}) = Bool
True
> is_shift LRAction
_                          = Bool
False

---
selects what counts as a reduction when calculating used/unused

> type SelectReductions = LRAction -> [Int]

> select_all_reductions :: SelectReductions
> select_all_reductions :: SelectReductions
select_all_reductions = SelectReductions
go
>   where go :: SelectReductions
go (LR'Reduce Int
r Priority
_)    = [Int
r]
>         go (LR'Multiple [LRAction]
as LRAction
a) = SelectReductions -> [LRAction] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SelectReductions
go (LRAction
a LRAction -> [LRAction] -> [LRAction]
forall a. a -> [a] -> [a]
: [LRAction]
as)
>         go LRAction
_                  = []

> select_first_reduction :: SelectReductions
> select_first_reduction :: SelectReductions
select_first_reduction = SelectReductions
go
>   where go :: SelectReductions
go (LR'Reduce Int
r Priority
_)   = [Int
r]
>         go (LR'Multiple [LRAction]
_ LRAction
a) = SelectReductions
go LRAction
a   -- eg R/R conflict
>         go LRAction
_                 = []