    > 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
    _                 = []