> 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], [(Name, 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 e ->
>     Tables
> genTables :: forall e. SelectReductions -> Grammar e -> Tables
genTables SelectReductions
select_reductions Grammar e
g =
>       let first :: [Name] -> NameSet
first       = {-# SCC "First" #-} (Grammar e -> [Name] -> NameSet
forall e. Grammar e -> [Name] -> NameSet
mkFirst Grammar e
g)
>           closures :: Name -> RuleList
closures    = {-# SCC "Closures" #-} (Grammar e -> Name -> RuleList
forall e. Grammar e -> Name -> RuleList
precalcClosure0 Grammar e
g)
>           lr0items :: [ItemSetWithGotos]
lr0items    = {-# SCC "LR0_Sets" #-} (Grammar e -> (Name -> RuleList) -> [ItemSetWithGotos]
forall e. Grammar e -> (Name -> RuleList) -> [ItemSetWithGotos]
genLR0items Grammar e
g Name -> RuleList
closures)
>           ([(Int, Lr0Item, NameSet)]
la_spont, Array Int [(Lr0Item, Int, Lr0Item)]
la_prop)
>                       = {-# SCC "Prop" #-} (Grammar e
-> [ItemSetWithGotos]
-> ([Name] -> NameSet)
-> ([(Int, Lr0Item, NameSet)], Array Int [(Lr0Item, Int, Lr0Item)])
forall e.
Grammar e
-> [ItemSetWithGotos]
-> ([Name] -> NameSet)
-> ([(Int, Lr0Item, NameSet)], Array Int [(Lr0Item, Int, Lr0Item)])
propLookaheads Grammar e
g [ItemSetWithGotos]
lr0items [Name] -> 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], [(Name, Int)])]
lr1items    = {-# SCC "Merge" #-} (Array Int [(Lr0Item, NameSet)]
-> [ItemSetWithGotos] -> [([Lr1Item], [(Name, Int)])]
mergeLookaheadInfo Array Int [(Lr0Item, NameSet)]
lookaheads [ItemSetWithGotos]
lr0items)
>           gotoTable :: GotoTable
gotoTable   = {-# SCC "Goto" #-} (Grammar e -> [ItemSetWithGotos] -> GotoTable
forall e. Grammar e -> [ItemSetWithGotos] -> GotoTable
genGotoTable Grammar e
g [ItemSetWithGotos]
lr0items)
>           actionTable :: ActionTable
actionTable = {-# SCC "Action" #-} (Grammar e
-> ([Name] -> NameSet)
-> [([Lr1Item], [(Name, Int)])]
-> ActionTable
forall e.
Grammar e
-> ([Name] -> NameSet)
-> [([Lr1Item], [(Name, Int)])]
-> ActionTable
genActionTable Grammar e
g [Name] -> NameSet
first [([Lr1Item], [(Name, 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 e -> ActionTable -> ([Int], [String])
forall e.
SelectReductions -> Grammar e -> ActionTable -> ([Int], [String])
find_redundancies SelectReductions
select_reductions Grammar e
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], [(Name, Int)])]
lr1items :: [([Lr1Item], [(Name, Int)])]
lr1items :: [([Lr1Item], [(Name, 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 e -> ActionTable -> ([Int], [String])
> find_redundancies :: forall e.
SelectReductions -> Grammar e -> ActionTable -> ([Int], [String])
find_redundancies SelectReductions
extract_reductions Grammar e
g ActionTable
action_table =
>       ([Int]
unused_rules, (Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Array Name String
env Array Name String -> Name -> String
forall i e. Ix i => Array i e -> i -> e
!) [Name]
unused_terminals)
>    where
>       Grammar { terminals :: forall eliminator. Grammar eliminator -> [Name]
terminals = [Name]
terms,
>                 token_names :: forall eliminator. Grammar eliminator -> Array Name String
token_names = Array Name String
env,
>                 eof_term :: forall eliminator. Grammar eliminator -> Name
eof_term = Name
eof,
>                 starts :: forall eliminator.
Grammar eliminator -> [(String, Name, Name, Bool)]
starts = [(String, Name, Name, Bool)]
starts',
>                 productions :: forall eliminator. Grammar eliminator -> [Production eliminator]
productions = [Production e]
productions'
>               } = Grammar e
g
>       actions :: [(Name, LRAction)]
actions          = [[(Name, LRAction)]] -> [(Name, LRAction)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Array Name LRAction -> [(Name, LRAction)])
-> [Array Name LRAction] -> [[(Name, LRAction)]]
forall a b. (a -> b) -> [a] -> [b]
map Array Name LRAction -> [(Name, LRAction)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs (ActionTable -> [Array Name LRAction]
forall i e. Array i e -> [e]
elems ActionTable
action_table))
>       start_rules :: [Int]
start_rules      = [ Int
0 .. ([(String, Name, Name, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Name, Name, 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 | (Name
_,LRAction
a) <- [(Name, LRAction)]
actions, Int
r <- SelectReductions
extract_reductions LRAction
a ]
>       used_tokens :: [Name]
used_tokens      = Name
errorTok Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Name
catchTok Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Name
eof Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:
>                              [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub [ Name
t | (Name
t,LRAction
a) <- [(Name, LRAction)]
actions, LRAction -> Bool
is_shift LRAction
a ]
>       n_prods :: Int
n_prods          = [Production e] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Production e]
productions'
>       unused_terminals :: [Name]
unused_terminals = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
used_tokens) [Name]
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
_                 = []