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