    -----------------------------------------------------------------------------
    Generation of LALR parsing tables.

    (c) 1993-1996 Andy Gill, Simon Marlow
    (c) 1997-2001 Simon Marlow
    -----------------------------------------------------------------------------

    > module Happy.Tabular.LALR
    >       (genActionTable, genGotoTable, genLR0items, precalcClosure0,
    >        propLookaheads, calcLookaheads, mergeLookaheadInfo, countConflicts,
    >        Lr0Item(..), Lr1Item(..), ItemSetWithGotos, LRAction(..), Lr1State,
    >        ActionTable, GotoTable, Goto(..))
    >       where

    > import Happy.Tabular.First ( mkClosure )
    > import Happy.Tabular.NameSet ( NameSet )
    > import qualified Happy.Tabular.NameSet as NameSet
    > import Happy.Grammar
    > import Data.IntSet ( IntSet )
    > import qualified Data.IntSet as IntSet hiding ( IntSet )
    > import Data.Set ( Set )
    > import qualified Data.Set as Set hiding ( Set )

    > import Control.Monad (guard)
    > import Control.Monad.ST
    > import Data.Array.ST
    > import Data.Array as Array
    > import Data.List (nub,foldl',groupBy,sortBy)
    > import Data.Function (on)
    > import Data.Maybe (listToMaybe, maybeToList)

    > unionMap :: (Ord b) => (a -> Set b) -> Set a -> Set b
    > unionMap :: forall b a. Ord b => (a -> Set b) -> Set a -> Set b
    unionMap a -> Set b
    f = (a -> Set b -> Set b) -> Set b -> Set a -> Set b
    forall a b. (a -> b -> b) -> b -> Set a -> b
    Set.foldr (Set b -> Set b -> Set b
    forall a. Ord a => Set a -> Set a -> Set a
    Set.union (Set b -> Set b -> Set b) -> (a -> Set b) -> a -> Set b -> Set b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Set b
    f) Set b
    forall a. Set a
    Set.empty

    > unionIntMap :: (Int -> IntSet) -> IntSet -> IntSet
    > unionIntMap :: (Int -> IntSet) -> IntSet -> IntSet
    unionIntMap Int -> IntSet
    f = (Int -> IntSet -> IntSet) -> IntSet -> IntSet -> IntSet
    forall b. (Int -> b -> b) -> b -> IntSet -> b
    IntSet.foldr (IntSet -> IntSet -> IntSet
    IntSet.union (IntSet -> IntSet -> IntSet)
    -> (Int -> IntSet) -> Int -> IntSet -> IntSet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> IntSet
    f) IntSet
    IntSet.empty

    > unionNameMap :: (Name -> NameSet) -> NameSet -> NameSet
    > unionNameMap :: (Name -> NameSet) -> NameSet -> NameSet
    unionNameMap Name -> NameSet
    f = (Name -> NameSet -> NameSet) -> NameSet -> NameSet -> NameSet
    forall b. (Name -> b -> b) -> b -> NameSet -> b
    NameSet.foldr (NameSet -> NameSet -> NameSet
    NameSet.union (NameSet -> NameSet -> NameSet)
    -> (Name -> NameSet) -> Name -> NameSet -> NameSet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> NameSet
    f) NameSet
    NameSet.empty

    -----------------------------------------------------------------------------

    This means rule $a$, with dot at $b$ (all starting at 0)

    > data Lr0Item = Lr0 {-#UNPACK#-}!Int {-#UNPACK#-}!Int          -- (rule, dot)
    >       deriving (Lr0Item -> Lr0Item -> Bool
    (Lr0Item -> Lr0Item -> Bool)
    -> (Lr0Item -> Lr0Item -> Bool) -> Eq Lr0Item
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Lr0Item -> Lr0Item -> Bool
    == :: Lr0Item -> Lr0Item -> Bool
    $c/= :: Lr0Item -> Lr0Item -> Bool
    /= :: Lr0Item -> Lr0Item -> Bool
    Eq,Eq Lr0Item
    Eq Lr0Item =>
    (Lr0Item -> Lr0Item -> Ordering)
    -> (Lr0Item -> Lr0Item -> Bool)
    -> (Lr0Item -> Lr0Item -> Bool)
    -> (Lr0Item -> Lr0Item -> Bool)
    -> (Lr0Item -> Lr0Item -> Bool)
    -> (Lr0Item -> Lr0Item -> Lr0Item)
    -> (Lr0Item -> Lr0Item -> Lr0Item)
    -> Ord Lr0Item
    Lr0Item -> Lr0Item -> Bool
    Lr0Item -> Lr0Item -> Ordering
    Lr0Item -> Lr0Item -> Lr0Item
    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
    $ccompare :: Lr0Item -> Lr0Item -> Ordering
    compare :: Lr0Item -> Lr0Item -> Ordering
    $c< :: Lr0Item -> Lr0Item -> Bool
    < :: Lr0Item -> Lr0Item -> Bool
    $c<= :: Lr0Item -> Lr0Item -> Bool
    <= :: Lr0Item -> Lr0Item -> Bool
    $c> :: Lr0Item -> Lr0Item -> Bool
    > :: Lr0Item -> Lr0Item -> Bool
    $c>= :: Lr0Item -> Lr0Item -> Bool
    >= :: Lr0Item -> Lr0Item -> Bool
    $cmax :: Lr0Item -> Lr0Item -> Lr0Item
    max :: Lr0Item -> Lr0Item -> Lr0Item
    $cmin :: Lr0Item -> Lr0Item -> Lr0Item
    min :: Lr0Item -> Lr0Item -> Lr0Item
    Ord,Int -> Lr0Item -> ShowS
    [Lr0Item] -> ShowS
    Lr0Item -> String
    (Int -> Lr0Item -> ShowS)
    -> (Lr0Item -> String) -> ([Lr0Item] -> ShowS) -> Show Lr0Item
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Lr0Item -> ShowS
    showsPrec :: Int -> Lr0Item -> ShowS
    $cshow :: Lr0Item -> String
    show :: Lr0Item -> String
    $cshowList :: [Lr0Item] -> ShowS
    showList :: [Lr0Item] -> ShowS
    Show)

    > data Lr1Item = Lr1 {-#UNPACK#-}!Int {-#UNPACK#-}!Int NameSet  -- (rule, dot, lookahead)
    >       deriving (Int -> Lr1Item -> ShowS
    [Lr1Item] -> ShowS
    Lr1Item -> String
    (Int -> Lr1Item -> ShowS)
    -> (Lr1Item -> String) -> ([Lr1Item] -> ShowS) -> Show Lr1Item
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Lr1Item -> ShowS
    showsPrec :: Int -> Lr1Item -> ShowS
    $cshow :: Lr1Item -> String
    show :: Lr1Item -> String
    $cshowList :: [Lr1Item] -> ShowS
    showList :: [Lr1Item] -> ShowS
    Show)

    > type RuleList = [Lr0Item]

    > type ItemSetWithGotos = (Set Lr0Item, [(Name,Int)])

    > data LRAction = LR'Shift Int Priority -- state number and priority
    >               | LR'Reduce Int Priority-- rule no and priority
    >               | LR'Accept             -- :-)
    >               | LR'Fail               -- :-(
    >               | LR'MustFail           -- :-(
    >               | LR'Multiple [LRAction] LRAction       -- conflict
    >       deriving (LRAction -> LRAction -> Bool
    (LRAction -> LRAction -> Bool)
    -> (LRAction -> LRAction -> Bool) -> Eq LRAction
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: LRAction -> LRAction -> Bool
    == :: LRAction -> LRAction -> Bool
    $c/= :: LRAction -> LRAction -> Bool
    /= :: LRAction -> LRAction -> Bool
    Eq,Int -> LRAction -> ShowS
    [LRAction] -> ShowS
    LRAction -> String
    (Int -> LRAction -> ShowS)
    -> (LRAction -> String) -> ([LRAction] -> ShowS) -> Show LRAction
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> LRAction -> ShowS
    showsPrec :: Int -> LRAction -> ShowS
    $cshow :: LRAction -> String
    show :: LRAction -> String
    $cshowList :: [LRAction] -> ShowS
    showList :: [LRAction] -> ShowS
    Show)

    > type ActionTable = Array Int{-state-} (Array Name{-terminal#-} LRAction)
    > type GotoTable = Array Int{-state-} (Array Name{-nonterminal #-} Goto)
    > data Goto = Goto Int | NoGoto
    >       deriving (Goto -> Goto -> Bool
    (Goto -> Goto -> Bool) -> (Goto -> Goto -> Bool) -> Eq Goto
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Goto -> Goto -> Bool
    == :: Goto -> Goto -> Bool
    $c/= :: Goto -> Goto -> Bool
    /= :: Goto -> Goto -> Bool
    Eq, Int -> Goto -> ShowS
    [Goto] -> ShowS
    Goto -> String
    (Int -> Goto -> ShowS)
    -> (Goto -> String) -> ([Goto] -> ShowS) -> Show Goto
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Goto -> ShowS
    showsPrec :: Int -> Goto -> ShowS
    $cshow :: Goto -> String
    show :: Goto -> String
    $cshowList :: [Goto] -> ShowS
    showList :: [Goto] -> ShowS
    Show)

    -----------------------------------------------------------------------------
    Token numbering in an array-based parser:

    % Action Table

    We have an action table, indexed by states in the y direction, and
    terminal number in the x direction.  ie. action = (state * n_terminals +
    terminal).  The terminal number is given by (for terminals only):

    	tok_number - n_nonterminals - 3

    so we have

    error		= 0
    terminals 	= 1..n
    %eof 		= n+1

    % Goto Table

    The goto table is indexed by nonterminal number (without %starts), ie

    	(state * (n_nonterminals-s)) + tok_number - s

    -----------------------------------------------------------------------------

    Generating the closure of a set of LR(0) items

    Precalculate the rule closure for each non-terminal in the grammar,
    using a memo table so that no work is repeated.

    > precalcClosure0 :: Grammar e -> Name -> RuleList
    > precalcClosure0 :: forall e. Grammar e -> Name -> [Lr0Item]
    precalcClosure0 Grammar e
    g =
    >       \Name
    n -> [Lr0Item]
    -> ([Lr0Item] -> [Lr0Item]) -> Maybe [Lr0Item] -> [Lr0Item]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] [Lr0Item] -> [Lr0Item]
    forall a. a -> a
    id (Name -> [(Name, [Lr0Item])] -> Maybe [Lr0Item]
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    n [(Name, [Lr0Item])]
    info')
    >  where
    >
    >       info' :: [(Name, RuleList)]
    >       info' :: [(Name, [Lr0Item])]
    info' = ((Name, IntSet) -> (Name, [Lr0Item]))
    -> [(Name, IntSet)] -> [(Name, [Lr0Item])]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name
    n,IntSet
    rules) -> (Name
    n,(Int -> Lr0Item) -> [Int] -> [Lr0Item]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    rule -> Int -> Int -> Lr0Item
    Lr0 Int
    rule Int
    0) (IntSet -> [Int]
    IntSet.toAscList IntSet
    rules))) [(Name, IntSet)]
    info

    >       info :: [(Name, IntSet)]
    >       info :: [(Name, IntSet)]
    info = ([(Name, IntSet)] -> [(Name, IntSet)] -> Bool)
    -> ([(Name, IntSet)] -> [(Name, IntSet)])
    -> [(Name, IntSet)]
    -> [(Name, IntSet)]
    forall a. (a -> a -> Bool) -> (a -> a) -> a -> a
    mkClosure [(Name, IntSet)] -> [(Name, IntSet)] -> Bool
    forall a. Eq a => a -> a -> Bool
    (==) (\[(Name, IntSet)]
    f -> ((Name, IntSet) -> (Name, IntSet))
    -> [(Name, IntSet)] -> [(Name, IntSet)]
    forall a b. (a -> b) -> [a] -> [b]
    map ([(Name, IntSet)] -> (Name, IntSet) -> (Name, IntSet)
    follow [(Name, IntSet)]
    f) [(Name, IntSet)]
    f)
    >                       ((Name -> (Name, IntSet)) -> [Name] -> [(Name, IntSet)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Name
    nt -> (Name
    nt,[Int] -> IntSet
    IntSet.fromList (Grammar e -> Name -> [Int]
    forall eliminator. Grammar eliminator -> Name -> [Int]
    lookupProdsOfName Grammar e
    g Name
    nt))) [Name]
    nts)

    >       follow :: [(Name, IntSet)] -> (Name, IntSet) -> (Name, IntSet)
    >       follow :: [(Name, IntSet)] -> (Name, IntSet) -> (Name, IntSet)
    follow [(Name, IntSet)]
    f (Name
    nt,IntSet
    rules) = (Name
    nt, (Int -> IntSet) -> IntSet -> IntSet
    unionIntMap ([(Name, IntSet)] -> Int -> IntSet
    followNT [(Name, IntSet)]
    f) IntSet
    rules IntSet -> IntSet -> IntSet
    `IntSet.union` IntSet
    rules)

    >       followNT :: [(Name, IntSet)] -> Int -> IntSet
    >       followNT :: [(Name, IntSet)] -> Int -> IntSet
    followNT [(Name, IntSet)]
    f Int
    rule =
    >               case Grammar e -> Int -> Int -> Maybe Name
    forall e. Grammar e -> Int -> Int -> Maybe Name
    findRule Grammar e
    g Int
    rule Int
    0 of
    >                       Just Name
    nt | Name
    nt Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Name
    firstStartTok Bool -> Bool -> Bool
    && Name
    nt Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    < Name
    fst_term ->
    >                               IntSet -> (IntSet -> IntSet) -> Maybe IntSet -> IntSet
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> IntSet
    forall a. HasCallStack => String -> a
    error String
    "followNT") IntSet -> IntSet
    forall a. a -> a
    id (Name -> [(Name, IntSet)] -> Maybe IntSet
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    nt [(Name, IntSet)]
    f)
    >                       Maybe Name
    _ -> IntSet
    IntSet.empty

    >       nts :: [Name]
    nts = Grammar e -> [Name]
    forall eliminator. Grammar eliminator -> [Name]
    non_terminals Grammar e
    g
    >       fst_term :: Name
    fst_term = Grammar e -> Name
    forall eliminator. Grammar eliminator -> Name
    first_term Grammar e
    g

    > closure0 :: Grammar e -> (Name -> RuleList) -> Set Lr0Item -> Set Lr0Item
    > closure0 :: forall e.
    Grammar e -> (Name -> [Lr0Item]) -> Set Lr0Item -> Set Lr0Item
    closure0 Grammar e
    g Name -> [Lr0Item]
    closureOfNT Set Lr0Item
    set = (Lr0Item -> Set Lr0Item -> Set Lr0Item)
    -> Set Lr0Item -> Set Lr0Item -> Set Lr0Item
    forall a b. (a -> b -> b) -> b -> Set a -> b
    Set.foldr Lr0Item -> Set Lr0Item -> Set Lr0Item
    addRules Set Lr0Item
    forall a. Set a
    Set.empty Set Lr0Item
    set
    >    where
    >       last_nonterm :: Name
    last_nonterm = Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Int
    getName (Grammar e -> Name
    forall eliminator. Grammar eliminator -> Name
    first_term Grammar e
    g) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1
    >       addRules :: Lr0Item -> Set Lr0Item -> Set Lr0Item
    addRules Lr0Item
    rule Set Lr0Item
    set' = Set Lr0Item -> Set Lr0Item -> Set Lr0Item
    forall a. Ord a => Set a -> Set a -> Set a
    Set.union ([Lr0Item] -> Set Lr0Item
    forall a. Ord a => [a] -> Set a
    Set.fromList (Lr0Item
    rule Lr0Item -> [Lr0Item] -> [Lr0Item]
    forall a. a -> [a] -> [a]
    : Lr0Item -> [Lr0Item]
    closureOfRule Lr0Item
    rule)) Set Lr0Item
    set'
    >
    >       closureOfRule :: Lr0Item -> [Lr0Item]
    closureOfRule (Lr0 Int
    rule Int
    dot) =
    >           case Grammar e -> Int -> Int -> Maybe Name
    forall e. Grammar e -> Int -> Int -> Maybe Name
    findRule Grammar e
    g Int
    rule Int
    dot of
    >               (Just Name
    nt) | Name
    nt Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Name
    firstStartTok Bool -> Bool -> Bool
    && Name
    nt Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Name
    last_nonterm
    >                  -> Name -> [Lr0Item]
    closureOfNT Name
    nt
    >               Maybe Name
    _  -> []

    -----------------------------------------------------------------------------
    Generating the closure of a set of LR(1) items

    > closure1 :: Grammar e -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
    > closure1 :: forall e.
    Grammar e -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
    closure1 Grammar e
    g [Name] -> NameSet
    first [Lr1Item]
    set
    >       = ([Lr1Item], [Lr1Item]) -> [Lr1Item]
    forall a b. (a, b) -> a
    fst ((([Lr1Item], [Lr1Item]) -> ([Lr1Item], [Lr1Item]) -> Bool)
    -> (([Lr1Item], [Lr1Item]) -> ([Lr1Item], [Lr1Item]))
    -> ([Lr1Item], [Lr1Item])
    -> ([Lr1Item], [Lr1Item])
    forall a. (a -> a -> Bool) -> (a -> a) -> a -> a
    mkClosure (\([Lr1Item]
    _,[Lr1Item]
    new) ([Lr1Item], [Lr1Item])
    _ -> [Lr1Item] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Lr1Item]
    new) ([Lr1Item], [Lr1Item]) -> ([Lr1Item], [Lr1Item])
    addItems ([],[Lr1Item]
    set))
    >       where
    >       last_nonterm :: Name
    last_nonterm = Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Int
    getName (Grammar e -> Name
    forall eliminator. Grammar eliminator -> Name
    first_term Grammar e
    g) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1

    >       addItems :: ([Lr1Item],[Lr1Item]) -> ([Lr1Item],[Lr1Item])
    >       addItems :: ([Lr1Item], [Lr1Item]) -> ([Lr1Item], [Lr1Item])
    addItems ([Lr1Item]
    old_items, [Lr1Item]
    new_items) = ([Lr1Item]
    new_old_items, [Lr1Item]
    new_new_items)
    >         where
    >               new_old_items :: [Lr1Item]
    new_old_items = [Lr1Item]
    new_items [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    `union_items` [Lr1Item]
    old_items
    >               new_new_items :: [Lr1Item]
    new_new_items = [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    subtract_items
    >                                  (([Lr1Item] -> [Lr1Item] -> [Lr1Item])
    -> [Lr1Item] -> [[Lr1Item]] -> [Lr1Item]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    union_items [] ((Lr1Item -> [Lr1Item]) -> [Lr1Item] -> [[Lr1Item]]
    forall a b. (a -> b) -> [a] -> [b]
    map Lr1Item -> [Lr1Item]
    fn [Lr1Item]
    new_items))
    >                                       [Lr1Item]
    new_old_items

    >               fn :: Lr1Item -> [Lr1Item]
    >               fn :: Lr1Item -> [Lr1Item]
    fn (Lr1 Int
    rule Int
    dot NameSet
    as) = case Int -> [Name] -> [Name]
    forall a. Int -> [a] -> [a]
    drop Int
    dot [Name]
    lhs of
    >                       (Name
    nt:[Name]
    beta) | Name
    nt Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Name
    firstStartTok Bool -> Bool -> Bool
    && Name
    nt Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Name
    last_nonterm ->
    >                           let terms :: NameSet
    terms = Name -> NameSet -> NameSet
    NameSet.delete Name
    catchTok (NameSet -> NameSet) -> NameSet -> NameSet
    forall a b. (a -> b) -> a -> b
    $ -- the catch token is always shifted and never reduced (see pop_items)
    >                                       (Name -> NameSet) -> NameSet -> NameSet
    unionNameMap (\Name
    a -> [Name] -> NameSet
    first ([Name]
    beta [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ [Name
    a])) NameSet
    as
    >                           in
    >                           [ (Int -> Int -> NameSet -> Lr1Item
    Lr1 Int
    rule' Int
    0 NameSet
    terms) | Int
    rule' <- Grammar e -> Name -> [Int]
    forall eliminator. Grammar eliminator -> Name -> [Int]
    lookupProdsOfName Grammar e
    g Name
    nt ]
    >                       [Name]
    _ -> []
    >                   where Production Name
    _name [Name]
    lhs (e, [Int])
    _ Priority
    _ = Grammar e -> Int -> Production e
    forall eliminator.
    Grammar eliminator -> Int -> Production eliminator
    lookupProdNo Grammar e
    g Int
    rule

    Subtract the first set of items from the second.

    > subtract_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    > subtract_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    subtract_items [Lr1Item]
    items1 [Lr1Item]
    items2 = (Lr1Item -> [Lr1Item] -> [Lr1Item])
    -> [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ([Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item]
    subtract_item [Lr1Item]
    items2) [] [Lr1Item]
    items1

    These utilities over item sets are crucial to performance.

    Stamp on overloading with judicious use of type signatures...

    > subtract_item :: [Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item]
    > subtract_item :: [Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item]
    subtract_item [] Lr1Item
    i [Lr1Item]
    result = Lr1Item
    i Lr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    : [Lr1Item]
    result
    > subtract_item ((Lr1 Int
    rule Int
    dot NameSet
    as):[Lr1Item]
    items) i :: Lr1Item
    i@(Lr1 Int
    rule' Int
    dot' NameSet
    as') [Lr1Item]
    result =
    >       case Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare Int
    rule' Int
    rule of
    >               Ordering
    LT -> Lr1Item
    i Lr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    : [Lr1Item]
    result
    >               Ordering
    GT -> [Lr1Item]
    carry_on
    >               Ordering
    EQ -> case Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare Int
    dot' Int
    dot of
    >                       Ordering
    LT -> Lr1Item
    i Lr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    : [Lr1Item]
    result
    >                       Ordering
    GT -> [Lr1Item]
    carry_on
    >                       Ordering
    EQ -> case NameSet -> NameSet -> NameSet
    NameSet.difference NameSet
    as' NameSet
    as of
    >                               NameSet
    bs | NameSet -> Bool
    NameSet.null NameSet
    bs -> [Lr1Item]
    result
    >                                  | Bool
    otherwise -> (Int -> Int -> NameSet -> Lr1Item
    Lr1 Int
    rule Int
    dot NameSet
    bs) Lr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    : [Lr1Item]
    result
    >  where
    >       carry_on :: [Lr1Item]
    carry_on = [Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item]
    subtract_item [Lr1Item]
    items Lr1Item
    i [Lr1Item]
    result

    Union two sets of items.

    > union_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    > union_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    union_items [Lr1Item]
    is [] = [Lr1Item]
    is
    > union_items [] [Lr1Item]
    is = [Lr1Item]
    is
    > union_items (i :: Lr1Item
    i@(Lr1 Int
    rule Int
    dot NameSet
    as):[Lr1Item]
    is) (i' :: Lr1Item
    i'@(Lr1 Int
    rule' Int
    dot' NameSet
    as'):[Lr1Item]
    is') =
    >       case Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare Int
    rule Int
    rule' of
    >               Ordering
    LT -> [Lr1Item]
    drop_i
    >               Ordering
    GT -> [Lr1Item]
    drop_i'
    >               Ordering
    EQ -> case Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare Int
    dot Int
    dot' of
    >                       Ordering
    LT -> [Lr1Item]
    drop_i
    >                       Ordering
    GT -> [Lr1Item]
    drop_i'
    >                       Ordering
    EQ -> (Int -> Int -> NameSet -> Lr1Item
    Lr1 Int
    rule Int
    dot (NameSet
    as NameSet -> NameSet -> NameSet
    `NameSet.union` NameSet
    as')) Lr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    : [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    union_items [Lr1Item]
    is [Lr1Item]
    is'
    >  where
    >       drop_i :: [Lr1Item]
    drop_i  = Lr1Item
    i  Lr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    : [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    union_items [Lr1Item]
    is (Lr1Item
    i'Lr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    :[Lr1Item]
    is')
    >       drop_i' :: [Lr1Item]
    drop_i' = Lr1Item
    i' Lr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    : [Lr1Item] -> [Lr1Item] -> [Lr1Item]
    union_items (Lr1Item
    iLr1Item -> [Lr1Item] -> [Lr1Item]
    forall a. a -> [a] -> [a]
    :[Lr1Item]
    is) [Lr1Item]
    is'

    -----------------------------------------------------------------------------
    goto(I,X) function

    The input should be the closure of a set of kernel items I together with
    a token X (terminal or non-terminal.  Output will be the set of kernel
    items for the set of items goto(I,X)

    > gotoClosure :: Grammar e -> Set Lr0Item -> Name -> Set Lr0Item
    > gotoClosure :: forall e. Grammar e -> Set Lr0Item -> Name -> Set Lr0Item
    gotoClosure Grammar e
    gram Set Lr0Item
    i Name
    x = (Lr0Item -> Set Lr0Item) -> Set Lr0Item -> Set Lr0Item
    forall b a. Ord b => (a -> Set b) -> Set a -> Set b
    unionMap Lr0Item -> Set Lr0Item
    fn Set Lr0Item
    i
    >    where
    >       fn :: Lr0Item -> Set Lr0Item
    fn (Lr0 Int
    rule_no Int
    dot) =
    >          case Grammar e -> Int -> Int -> Maybe Name
    forall e. Grammar e -> Int -> Int -> Maybe Name
    findRule Grammar e
    gram Int
    rule_no Int
    dot of
    >               Just Name
    t | Name
    x Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    t -> Lr0Item -> Set Lr0Item
    forall a. a -> Set a
    Set.singleton (Int -> Int -> Lr0Item
    Lr0 Int
    rule_no (Int
    dotInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1))
    >               Maybe Name
    _ -> Set Lr0Item
    forall a. Set a
    Set.empty

    -----------------------------------------------------------------------------
    Generating LR0 Item sets

    The item sets are generated in much the same way as we find the
    closure of a set of items: we use two sets, those which have already
    generated more sets, and those which have just been generated.  We
    keep iterating until the second set is empty.

    The addItems function is complicated by the fact that we need to keep
    information about which sets were generated by which others.

    > genLR0items :: Grammar e -> (Name -> RuleList) -> [ItemSetWithGotos]
    > genLR0items :: forall e. Grammar e -> (Name -> [Lr0Item]) -> [ItemSetWithGotos]
    genLR0items Grammar e
    g Name -> [Lr0Item]
    precalcClosures
    >       = ([ItemSetWithGotos], [Set Lr0Item]) -> [ItemSetWithGotos]
    forall a b. (a, b) -> a
    fst ((([ItemSetWithGotos], [Set Lr0Item])
     -> ([ItemSetWithGotos], [Set Lr0Item]) -> Bool)
    -> (([ItemSetWithGotos], [Set Lr0Item])
        -> ([ItemSetWithGotos], [Set Lr0Item]))
    -> ([ItemSetWithGotos], [Set Lr0Item])
    -> ([ItemSetWithGotos], [Set Lr0Item])
    forall a. (a -> a -> Bool) -> (a -> a) -> a -> a
    mkClosure (\([ItemSetWithGotos]
    _,[Set Lr0Item]
    new) ([ItemSetWithGotos], [Set Lr0Item])
    _ -> [Set Lr0Item] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Set Lr0Item]
    new)
    >               ([ItemSetWithGotos], [Set Lr0Item])
    -> ([ItemSetWithGotos], [Set Lr0Item])
    addItems
    >                 (([],[Set Lr0Item]
    startRules)))
    >  where

    >    n_starts :: Int
    n_starts = [(String, Name, Name, Bool)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (Grammar e -> [(String, Name, Name, Bool)]
    forall eliminator.
    Grammar eliminator -> [(String, Name, Name, Bool)]
    starts Grammar e
    g)
    >    startRules :: [Set Lr0Item]
    >    startRules :: [Set Lr0Item]
    startRules = [ Lr0Item -> Set Lr0Item
    forall a. a -> Set a
    Set.singleton (Int -> Int -> Lr0Item
    Lr0 Int
    rule Int
    0) | Int
    rule <- [Int
    0..Int
    n_starts] ]

    >    tokens :: [Name]
    tokens = Grammar e -> [Name]
    forall eliminator. Grammar eliminator -> [Name]
    non_terminals Grammar e
    g [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Grammar e -> [Name]
    forall eliminator. Grammar eliminator -> [Name]
    terminals Grammar e
    g

    >    addItems :: ([ItemSetWithGotos], [Set Lr0Item])
    >             -> ([ItemSetWithGotos], [Set Lr0Item])
    >
    >    addItems :: ([ItemSetWithGotos], [Set Lr0Item])
    -> ([ItemSetWithGotos], [Set Lr0Item])
    addItems ([ItemSetWithGotos]
    oldSets,[Set Lr0Item]
    newSets) = ([ItemSetWithGotos]
    newOldSets, [Set Lr0Item] -> [Set Lr0Item]
    forall a. [a] -> [a]
    reverse [Set Lr0Item]
    newNewSets)
    >     where
    >
    >       newOldSets :: [ItemSetWithGotos]
    newOldSets = [ItemSetWithGotos]
    oldSets [ItemSetWithGotos] -> [ItemSetWithGotos] -> [ItemSetWithGotos]
    forall a. [a] -> [a] -> [a]
    ++ ([Set Lr0Item] -> [[(Name, Int)]] -> [ItemSetWithGotos]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Set Lr0Item]
    newSets [[(Name, Int)]]
    intgotos)

    >       itemSets :: [Set Lr0Item]
    itemSets = (ItemSetWithGotos -> Set Lr0Item)
    -> [ItemSetWithGotos] -> [Set Lr0Item]
    forall a b. (a -> b) -> [a] -> [b]
    map ItemSetWithGotos -> Set Lr0Item
    forall a b. (a, b) -> a
    fst [ItemSetWithGotos]
    oldSets [Set Lr0Item] -> [Set Lr0Item] -> [Set Lr0Item]
    forall a. [a] -> [a] -> [a]
    ++ [Set Lr0Item]
    newSets

    First thing to do is for each set in I in newSets, generate goto(I,X)
    for each token (terminals and nonterminals) X.

    >       gotos :: [[(Name,Set Lr0Item)]]
    >       gotos :: [[(Name, Set Lr0Item)]]
    gotos = ([(Name, Set Lr0Item)] -> [(Name, Set Lr0Item)])
    -> [[(Name, Set Lr0Item)]] -> [[(Name, Set Lr0Item)]]
    forall a b. (a -> b) -> [a] -> [b]
    map (((Name, Set Lr0Item) -> Bool)
    -> [(Name, Set Lr0Item)] -> [(Name, Set Lr0Item)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool)
    -> ((Name, Set Lr0Item) -> Bool) -> (Name, Set Lr0Item) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Set Lr0Item -> Bool
    forall a. Set a -> Bool
    Set.null (Set Lr0Item -> Bool)
    -> ((Name, Set Lr0Item) -> Set Lr0Item)
    -> (Name, Set Lr0Item)
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name, Set Lr0Item) -> Set Lr0Item
    forall a b. (a, b) -> b
    snd))
    >           ((Set Lr0Item -> [(Name, Set Lr0Item)])
    -> [Set Lr0Item] -> [[(Name, Set Lr0Item)]]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Set Lr0Item
    i -> let i' :: Set Lr0Item
    i' = Grammar e -> (Name -> [Lr0Item]) -> Set Lr0Item -> Set Lr0Item
    forall e.
    Grammar e -> (Name -> [Lr0Item]) -> Set Lr0Item -> Set Lr0Item
    closure0 Grammar e
    g Name -> [Lr0Item]
    precalcClosures Set Lr0Item
    i in
    >                       [ (Name
    x,Grammar e -> Set Lr0Item -> Name -> Set Lr0Item
    forall e. Grammar e -> Set Lr0Item -> Name -> Set Lr0Item
    gotoClosure Grammar e
    g Set Lr0Item
    i' Name
    x) | Name
    x <- [Name]
    tokens ]) [Set Lr0Item]
    newSets)

    Next, we assign each new set a number, which is the index of this set
    in the list of sets comprising all the sets generated so far plus
    those generated in this iteration.  We also filter out those sets that
    are new, i.e. don't exist in the current list of sets, so that they
    can be added.

    We also have to make sure that there are no duplicate sets in the
    *current* batch of goto(I,X) sets, as this could be disastrous.  I
    think I've squished this one with the '++ reverse newSets' in
    numberSets.

    numberSets is built this way so we can use it quite neatly with a foldr.
    Unfortunately, the code's a little opaque.

    >       numberSets
    >               :: [(Name,Set Lr0Item)]
    >               -> (Int,
    >                   [[(Name,Int)]],
    >                   [Set Lr0Item])
    >               -> (Int, [[(Name,Int)]], [Set Lr0Item])
    >
    >       numberSets :: [(Name, Set Lr0Item)]
    -> (Int, [[(Name, Int)]], [Set Lr0Item])
    -> (Int, [[(Name, Int)]], [Set Lr0Item])
    numberSets [] (Int
    i,[[(Name, Int)]]
    gotos',[Set Lr0Item]
    newSets') = (Int
    i,([][(Name, Int)] -> [[(Name, Int)]] -> [[(Name, Int)]]
    forall a. a -> [a] -> [a]
    :[[(Name, Int)]]
    gotos'),[Set Lr0Item]
    newSets')
    >       numberSets ((Name
    x,Set Lr0Item
    gotoix):[(Name, Set Lr0Item)]
    rest) (Int
    i,[(Name, Int)]
    g':[[(Name, Int)]]
    gotos',[Set Lr0Item]
    newSets')
    >          = [(Name, Set Lr0Item)]
    -> (Int, [[(Name, Int)]], [Set Lr0Item])
    -> (Int, [[(Name, Int)]], [Set Lr0Item])
    numberSets [(Name, Set Lr0Item)]
    rest
    >               (case Int -> Set Lr0Item -> [Set Lr0Item] -> Maybe Int
    forall a. Eq a => Int -> a -> [a] -> Maybe Int
    indexInto Int
    0 Set Lr0Item
    gotoix ([Set Lr0Item]
    itemSets [Set Lr0Item] -> [Set Lr0Item] -> [Set Lr0Item]
    forall a. [a] -> [a] -> [a]
    ++ [Set Lr0Item] -> [Set Lr0Item]
    forall a. [a] -> [a]
    reverse [Set Lr0Item]
    newSets') of
    >                       Just Int
    j  -> (Int
    i,  ((Name
    x,Int
    j)(Name, Int) -> [(Name, Int)] -> [(Name, Int)]
    forall a. a -> [a] -> [a]
    :[(Name, Int)]
    g')[(Name, Int)] -> [[(Name, Int)]] -> [[(Name, Int)]]
    forall a. a -> [a] -> [a]
    :[[(Name, Int)]]
    gotos', [Set Lr0Item]
    newSets')
    >                       Maybe Int
    Nothing -> (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1,((Name
    x,Int
    i)(Name, Int) -> [(Name, Int)] -> [(Name, Int)]
    forall a. a -> [a] -> [a]
    :[(Name, Int)]
    g')[(Name, Int)] -> [[(Name, Int)]] -> [[(Name, Int)]]
    forall a. a -> [a] -> [a]
    :[[(Name, Int)]]
    gotos', Set Lr0Item
    gotoixSet Lr0Item -> [Set Lr0Item] -> [Set Lr0Item]
    forall a. a -> [a] -> [a]
    :[Set Lr0Item]
    newSets'))
    >       numberSets [(Name, Set Lr0Item)]
    _ (Int, [[(Name, Int)]], [Set Lr0Item])
    _ = String -> (Int, [[(Name, Int)]], [Set Lr0Item])
    forall a. HasCallStack => String -> a
    error String
    "genLR0items/numberSets: Unhandled case"

    Finally, do some fiddling around to get this all in the form we want.

    >       intgotos :: [[(Name,Int)]]
    >       newNewSets  :: [Set Lr0Item]
    >       (Int
    _, ([]:[[(Name, Int)]]
    intgotos), [Set Lr0Item]
    newNewSets) =
    >               ([(Name, Set Lr0Item)]
     -> (Int, [[(Name, Int)]], [Set Lr0Item])
     -> (Int, [[(Name, Int)]], [Set Lr0Item]))
    -> (Int, [[(Name, Int)]], [Set Lr0Item])
    -> [[(Name, Set Lr0Item)]]
    -> (Int, [[(Name, Int)]], [Set Lr0Item])
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr [(Name, Set Lr0Item)]
    -> (Int, [[(Name, Int)]], [Set Lr0Item])
    -> (Int, [[(Name, Int)]], [Set Lr0Item])
    numberSets ([ItemSetWithGotos] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [ItemSetWithGotos]
    newOldSets, [[]], []) [[(Name, Set Lr0Item)]]
    gotos

    > indexInto :: Eq a => Int -> a -> [a] -> Maybe Int
    > indexInto :: forall a. Eq a => Int -> a -> [a] -> Maybe Int
    indexInto Int
    _ a
    _ []                 = Maybe Int
    forall a. Maybe a
    Nothing
    > indexInto Int
    i a
    x (a
    y:[a]
    ys) | a
    x a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    y    = Int -> Maybe Int
    forall a. a -> Maybe a
    Just Int
    i
    >                      | Bool
    otherwise = let j :: Int
    j = Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1 in Int
    j Int -> Maybe Int -> Maybe Int
    forall a b. a -> b -> b
    `seq` Int -> a -> [a] -> Maybe Int
    forall a. Eq a => Int -> a -> [a] -> Maybe Int
    indexInto Int
    j a
    x [a]
    ys

    -----------------------------------------------------------------------------
    Computing propagation of lookaheads

    ToDo: generate this info into an array to be used in the subsequent
    calcLookaheads pass.

    > propLookaheads
    >       :: Grammar e
    >       -> [ItemSetWithGotos]                   -- ^ LR(0) kernel sets
    >       -> ([Name] -> NameSet)                  -- ^ First function
    >       -> (
    >               [(Int, Lr0Item, NameSet)],      -- spontaneous lookaheads
    >               Array Int [(Lr0Item, Int, Lr0Item)]     -- propagated lookaheads
    >          )

    > propLookaheads :: forall e.
    Grammar e
    -> [ItemSetWithGotos]
    -> ([Name] -> NameSet)
    -> ([(Int, Lr0Item, NameSet)], Array Int [(Lr0Item, Int, Lr0Item)])
    propLookaheads Grammar e
    gram [ItemSetWithGotos]
    sets [Name] -> NameSet
    first = ([[(Int, Lr0Item, NameSet)]] -> [(Int, Lr0Item, NameSet)]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[(Int, Lr0Item, NameSet)]]
    s, (Int, Int)
    -> [(Int, [(Lr0Item, Int, Lr0Item)])]
    -> Array Int [(Lr0Item, Int, Lr0Item)]
    forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
    array (Int
    0,[ItemSetWithGotos] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [ItemSetWithGotos]
    sets Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)
    >                       [ (Int
    a,[(Lr0Item, Int, Lr0Item)]
    b) | (Int
    a,[(Lr0Item, Int, Lr0Item)]
    b) <- [(Int, [(Lr0Item, Int, Lr0Item)])]
    p ])
    >   where

    >     ([[(Int, Lr0Item, NameSet)]]
    s,[(Int, [(Lr0Item, Int, Lr0Item)])]
    p) = [([(Int, Lr0Item, NameSet)], (Int, [(Lr0Item, Int, Lr0Item)]))]
    -> ([[(Int, Lr0Item, NameSet)]],
        [(Int, [(Lr0Item, Int, Lr0Item)])])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ((ItemSetWithGotos
     -> Int
     -> ([(Int, Lr0Item, NameSet)], (Int, [(Lr0Item, Int, Lr0Item)])))
    -> [ItemSetWithGotos]
    -> [Int]
    -> [([(Int, Lr0Item, NameSet)], (Int, [(Lr0Item, Int, Lr0Item)]))]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith ItemSetWithGotos
    -> Int
    -> ([(Int, Lr0Item, NameSet)], (Int, [(Lr0Item, Int, Lr0Item)]))
    propLASet [ItemSetWithGotos]
    sets [Int
    0..])

    >     propLASet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([(Int, Lr0Item, NameSet)],(Int,[(Lr0Item, Int, Lr0Item)]))
    >     propLASet :: ItemSetWithGotos
    -> Int
    -> ([(Int, Lr0Item, NameSet)], (Int, [(Lr0Item, Int, Lr0Item)]))
    propLASet (Set Lr0Item
    set,[(Name, Int)]
    goto) Int
    i = ([(Int, Lr0Item, NameSet)]
    start_spont [(Int, Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)]
    forall a. [a] -> [a] -> [a]
    ++ [[(Int, Lr0Item, NameSet)]] -> [(Int, Lr0Item, NameSet)]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[(Int, Lr0Item, NameSet)]]
    s', (Int
    i, [[(Lr0Item, Int, Lr0Item)]] -> [(Lr0Item, Int, Lr0Item)]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[(Lr0Item, Int, Lr0Item)]]
    p'))
    >       where

    >         ([[(Int, Lr0Item, NameSet)]]
    s',[[(Lr0Item, Int, Lr0Item)]]
    p') = [([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)])]
    -> ([[(Int, Lr0Item, NameSet)]], [[(Lr0Item, Int, Lr0Item)]])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ((Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)]))
    -> [Lr0Item]
    -> [([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)])]
    forall a b. (a -> b) -> [a] -> [b]
    map Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)])
    propLAItem (Set Lr0Item -> [Lr0Item]
    forall a. Set a -> [a]
    Set.toAscList Set Lr0Item
    set))

    >         -- spontaneous EOF lookaheads for each start state & rule...
    >         start_info :: [(String, Name, Name, Bool)]
    >         start_info :: [(String, Name, Name, Bool)]
    start_info = Grammar e -> [(String, Name, Name, Bool)]
    forall eliminator.
    Grammar eliminator -> [(String, Name, Name, Bool)]
    starts Grammar e
    gram

    >         start_spont :: [(Int, Lr0Item ,NameSet)]
    >         start_spont :: [(Int, Lr0Item, NameSet)]
    start_spont   = [ (Int
    start, (Int -> Int -> Lr0Item
    Lr0 Int
    start Int
    0),
    >                            Name -> NameSet
    NameSet.singleton (Grammar e -> Bool -> Name
    forall e. Grammar e -> Bool -> Name
    startLookahead Grammar e
    gram Bool
    partial))
    >                         | (Int
    start, (String
    _,Name
    _,Name
    _,Bool
    partial)) <-
    >                               [Int]
    -> [(String, Name, Name, Bool)]
    -> [(Int, (String, Name, Name, Bool))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] [(String, Name, Name, Bool)]
    start_info]

    >         propLAItem :: Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)])
    >         propLAItem :: Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)])
    propLAItem item :: Lr0Item
    item@(Lr0 Int
    rule Int
    dot) = ([(Int, Lr0Item, NameSet)]
    spontaneous, [(Lr0Item, Int, Lr0Item)]
    propagated)
    >           where
    >               lookupGoto :: String -> Name -> Int
    lookupGoto String
    msg Name
    x = Int -> (Int -> Int) -> Maybe Int -> Int
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Int
    forall a. HasCallStack => String -> a
    error String
    msg) Int -> Int
    forall a. a -> a
    id (Name -> [(Name, Int)] -> Maybe Int
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    x [(Name, Int)]
    goto)

    >               j :: [Lr1Item]
    j = Grammar e -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
    forall e.
    Grammar e -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
    closure1 Grammar e
    gram [Name] -> NameSet
    first [Int -> Int -> NameSet -> Lr1Item
    Lr1 Int
    rule Int
    dot (Name -> NameSet
    NameSet.singleton Name
    dummyTok)]

    >               spontaneous :: [(Int, Lr0Item, NameSet)]
    >               spontaneous :: [(Int, Lr0Item, NameSet)]
    spontaneous = do
    >                   (Lr1 rule' dot' ts) <- [Lr1Item]
    j
    >                   let ts' = Name -> NameSet -> NameSet
    NameSet.delete Name
    dummyTok NameSet
    ts
    >                   guard (not $ NameSet.null ts')
    >                   maybeToList $ do r <- findRule gram rule' dot'
    >                                    return ( lookupGoto "spontaneous" r
    >                                           , Lr0 rule' (dot' + 1)
    >                                           , ts' )

    >               propagated :: [(Lr0Item, Int, Lr0Item)]
    >               propagated :: [(Lr0Item, Int, Lr0Item)]
    propagated = do
    >                   (Lr1 rule' dot' ts) <- [Lr1Item]
    j
    >                   guard $ NameSet.member dummyTok ts
    >                   maybeToList $ do r <- findRule gram rule' dot'
    >                                    return ( item
    >                                           , lookupGoto "propagated" r
    >                                           , Lr0 rule' (dot' + 1) )

    The lookahead for a start rule depends on whether it was declared
    with %name or %partial: a %name parser is assumed to parse the whole
    input, ending with EOF, whereas a %partial parser may parse only a
    part of the input: it accepts when the error token is found.

    > startLookahead :: Grammar e -> Bool -> Name
    > startLookahead :: forall e. Grammar e -> Bool -> Name
    startLookahead Grammar e
    gram Bool
    partial = if Bool
    partial then Name
    errorTok else Grammar e -> Name
    forall eliminator. Grammar eliminator -> Name
    eof_term Grammar e
    gram

    -----------------------------------------------------------------------------
    Calculate lookaheads

    Special version using a mutable array:

    > calcLookaheads
    >       :: Int                                  -- number of states
    >       -> [(Int, Lr0Item, NameSet)]            -- spontaneous lookaheads
    >       -> Array Int [(Lr0Item, Int, Lr0Item)]  -- propagated lookaheads
    >       -> Array Int [(Lr0Item, NameSet)]

    > calcLookaheads :: Int
    -> [(Int, Lr0Item, NameSet)]
    -> Array Int [(Lr0Item, Int, Lr0Item)]
    -> Array Int [(Lr0Item, NameSet)]
    calcLookaheads Int
    n_states [(Int, Lr0Item, NameSet)]
    spont Array Int [(Lr0Item, Int, Lr0Item)]
    prop
    >       = (forall s. ST s (Array Int [(Lr0Item, NameSet)]))
    -> Array Int [(Lr0Item, NameSet)]
    forall a. (forall s. ST s a) -> a
    runST ((forall s. ST s (Array Int [(Lr0Item, NameSet)]))
     -> Array Int [(Lr0Item, NameSet)])
    -> (forall s. ST s (Array Int [(Lr0Item, NameSet)]))
    -> Array Int [(Lr0Item, NameSet)]
    forall a b. (a -> b) -> a -> b
    $ do
    >           arr <- (Int, Int)
    -> [(Lr0Item, NameSet)]
    -> ST s (STArray s Int [(Lr0Item, NameSet)])
    forall i.
    Ix i =>
    (i, i)
    -> [(Lr0Item, NameSet)] -> ST s (STArray s i [(Lr0Item, NameSet)])
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> e -> m (a i e)
    newArray (Int
    0,Int
    n_states) []
    >           propagate arr (fold_lookahead spont)
    >           freeze arr

    >   where
    >       propagate :: STArray s Int [(Lr0Item, NameSet)]
    >                        -> [(Int, Lr0Item, NameSet)] -> ST s ()
    >       propagate :: forall s.
    STArray s Int [(Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)] -> ST s ()
    propagate STArray s Int [(Lr0Item, NameSet)]
    _   []  = () -> ST s ()
    forall a. a -> ST s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    >       propagate STArray s Int [(Lr0Item, NameSet)]
    arr [(Int, Lr0Item, NameSet)]
    new = do
    >               let
    >                  items :: [(Int, Lr0Item, NameSet)]
    items = [ (Int
    i,Lr0Item
    item'',NameSet
    s) | (Int
    j,Lr0Item
    item,NameSet
    s) <- [(Int, Lr0Item, NameSet)]
    new,
    >                                           (Lr0Item
    item',Int
    i,Lr0Item
    item'') <- Array Int [(Lr0Item, Int, Lr0Item)]
    prop Array Int [(Lr0Item, Int, Lr0Item)]
    -> Int -> [(Lr0Item, Int, Lr0Item)]
    forall i e. Ix i => Array i e -> i -> e
    ! Int
    j,
    >                                           Lr0Item
    item Lr0Item -> Lr0Item -> Bool
    forall a. Eq a => a -> a -> Bool
    == Lr0Item
    item' ]
    >               new_new <- STArray s Int [(Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    -> ST s [(Int, Lr0Item, NameSet)]
    forall s.
    STArray s Int [(Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    -> ST s [(Int, Lr0Item, NameSet)]
    get_new STArray s Int [(Lr0Item, NameSet)]
    arr [(Int, Lr0Item, NameSet)]
    items []
    >               add_lookaheads arr new
    >               propagate arr new_new

    This function is needed to merge all the (set_no,item,name) triples
    into (set_no, item, set name) triples.  It can be removed when we get
    the spontaneous lookaheads in the right form to begin with (ToDo).

    > add_lookaheads :: STArray s Int [(Lr0Item, NameSet)]
    >                -> [(Int, Lr0Item, NameSet)]
    >                -> ST s ()
    > add_lookaheads :: forall s.
    STArray s Int [(Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)] -> ST s ()
    add_lookaheads STArray s Int [(Lr0Item, NameSet)]
    arr = ((Int, Lr0Item, NameSet) -> ST s ())
    -> [(Int, Lr0Item, NameSet)] -> ST s ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (((Int, Lr0Item, NameSet) -> ST s ())
     -> [(Int, Lr0Item, NameSet)] -> ST s ())
    -> ((Int, Lr0Item, NameSet) -> ST s ())
    -> [(Int, Lr0Item, NameSet)]
    -> ST s ()
    forall a b. (a -> b) -> a -> b
    $ \(Int
    i,Lr0Item
    item,NameSet
    s)
    >                    -> do las <- STArray s Int [(Lr0Item, NameSet)]
    -> Int -> ST s [(Lr0Item, NameSet)]
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STArray s Int [(Lr0Item, NameSet)]
    arr Int
    i
    >                          writeArray arr i (add_lookahead item s las)

    > get_new :: STArray s Int [(Lr0Item, NameSet)]
    >         -> [(Int, Lr0Item, NameSet)]
    >         -> [(Int, Lr0Item, NameSet)]
    >         -> ST s [(Int, Lr0Item, NameSet)]
    > get_new :: forall s.
    STArray s Int [(Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    -> ST s [(Int, Lr0Item, NameSet)]
    get_new STArray s Int [(Lr0Item, NameSet)]
    _   []                   [(Int, Lr0Item, NameSet)]
    new = [(Int, Lr0Item, NameSet)] -> ST s [(Int, Lr0Item, NameSet)]
    forall a. a -> ST s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(Int, Lr0Item, NameSet)]
    new
    > get_new STArray s Int [(Lr0Item, NameSet)]
    arr (l :: (Int, Lr0Item, NameSet)
    l@(Int
    i,Lr0Item
    _item,NameSet
    _s):[(Int, Lr0Item, NameSet)]
    las) [(Int, Lr0Item, NameSet)]
    new = do
    >       state_las <- STArray s Int [(Lr0Item, NameSet)]
    -> Int -> ST s [(Lr0Item, NameSet)]
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STArray s Int [(Lr0Item, NameSet)]
    arr Int
    i
    >       get_new arr las (get_new' l state_las new)

    > add_lookahead :: Lr0Item -> NameSet -> [(Lr0Item,NameSet)] ->
    >                       [(Lr0Item,NameSet)]
    > add_lookahead :: Lr0Item -> NameSet -> [(Lr0Item, NameSet)] -> [(Lr0Item, NameSet)]
    add_lookahead Lr0Item
    item NameSet
    s [] = [(Lr0Item
    item,NameSet
    s)]
    > add_lookahead Lr0Item
    item NameSet
    s (m :: (Lr0Item, NameSet)
    m@(Lr0Item
    item',NameSet
    s') : [(Lr0Item, NameSet)]
    las)
    >       | Lr0Item
    item Lr0Item -> Lr0Item -> Bool
    forall a. Eq a => a -> a -> Bool
    == Lr0Item
    item' = (Lr0Item
    item, NameSet
    s NameSet -> NameSet -> NameSet
    `NameSet.union` NameSet
    s') (Lr0Item, NameSet) -> [(Lr0Item, NameSet)] -> [(Lr0Item, NameSet)]
    forall a. a -> [a] -> [a]
    : [(Lr0Item, NameSet)]
    las
    >       | Bool
    otherwise     = (Lr0Item, NameSet)
    m (Lr0Item, NameSet) -> [(Lr0Item, NameSet)] -> [(Lr0Item, NameSet)]
    forall a. a -> [a] -> [a]
    : Lr0Item -> NameSet -> [(Lr0Item, NameSet)] -> [(Lr0Item, NameSet)]
    add_lookahead Lr0Item
    item NameSet
    s [(Lr0Item, NameSet)]
    las

    > get_new' :: (Int,Lr0Item,NameSet) -> [(Lr0Item,NameSet)] ->
    >                [(Int,Lr0Item,NameSet)] -> [(Int,Lr0Item,NameSet)]
    > get_new' :: (Int, Lr0Item, NameSet)
    -> [(Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    get_new' (Int, Lr0Item, NameSet)
    l [] [(Int, Lr0Item, NameSet)]
    new = (Int, Lr0Item, NameSet)
    l (Int, Lr0Item, NameSet)
    -> [(Int, Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)]
    forall a. a -> [a] -> [a]
    : [(Int, Lr0Item, NameSet)]
    new
    > get_new' l :: (Int, Lr0Item, NameSet)
    l@(Int
    i,Lr0Item
    item,NameSet
    s) ((Lr0Item
    item',NameSet
    s') : [(Lr0Item, NameSet)]
    las) [(Int, Lr0Item, NameSet)]
    new
    >       | Lr0Item
    item Lr0Item -> Lr0Item -> Bool
    forall a. Eq a => a -> a -> Bool
    == Lr0Item
    item' =
    >               let s'' :: NameSet
    s'' = NameSet
    s NameSet -> NameSet -> NameSet
    NameSet.\\ NameSet
    s' in
    >               if NameSet -> Bool
    NameSet.null NameSet
    s'' then [(Int, Lr0Item, NameSet)]
    new else (Int
    i,Lr0Item
    item,NameSet
    s'') (Int, Lr0Item, NameSet)
    -> [(Int, Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)]
    forall a. a -> [a] -> [a]
    : [(Int, Lr0Item, NameSet)]
    new
    >       | Bool
    otherwise =
    >               (Int, Lr0Item, NameSet)
    -> [(Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    get_new' (Int, Lr0Item, NameSet)
    l [(Lr0Item, NameSet)]
    las [(Int, Lr0Item, NameSet)]
    new

    > fold_lookahead :: [(Int,Lr0Item,NameSet)] -> [(Int,Lr0Item,NameSet)]
    > fold_lookahead :: [(Int, Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)]
    fold_lookahead =
    >     ([((Int, Lr0Item), NameSet)] -> (Int, Lr0Item, NameSet))
    -> [[((Int, Lr0Item), NameSet)]] -> [(Int, Lr0Item, NameSet)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\cs :: [((Int, Lr0Item), NameSet)]
    cs@(((Int
    a,Lr0Item
    b),NameSet
    _):[((Int, Lr0Item), NameSet)]
    _) -> (Int
    a,Lr0Item
    b,[NameSet] -> NameSet
    NameSet.unions ([NameSet] -> NameSet) -> [NameSet] -> NameSet
    forall a b. (a -> b) -> a -> b
    $ (((Int, Lr0Item), NameSet) -> NameSet)
    -> [((Int, Lr0Item), NameSet)] -> [NameSet]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Int, Lr0Item), NameSet) -> NameSet
    forall a b. (a, b) -> b
    snd [((Int, Lr0Item), NameSet)]
    cs)) ([[((Int, Lr0Item), NameSet)]] -> [(Int, Lr0Item, NameSet)])
    -> ([(Int, Lr0Item, NameSet)] -> [[((Int, Lr0Item), NameSet)]])
    -> [(Int, Lr0Item, NameSet)]
    -> [(Int, Lr0Item, NameSet)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
    >     (((Int, Lr0Item), NameSet) -> ((Int, Lr0Item), NameSet) -> Bool)
    -> [((Int, Lr0Item), NameSet)] -> [[((Int, Lr0Item), NameSet)]]
    forall a. (a -> a -> Bool) -> [a] -> [[a]]
    groupBy ((Int, Lr0Item) -> (Int, Lr0Item) -> Bool
    forall a. Eq a => a -> a -> Bool
    (==) ((Int, Lr0Item) -> (Int, Lr0Item) -> Bool)
    -> (((Int, Lr0Item), NameSet) -> (Int, Lr0Item))
    -> ((Int, Lr0Item), NameSet)
    -> ((Int, Lr0Item), NameSet)
    -> Bool
    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
    `on` ((Int, Lr0Item), NameSet) -> (Int, Lr0Item)
    forall a b. (a, b) -> a
    fst) ([((Int, Lr0Item), NameSet)] -> [[((Int, Lr0Item), NameSet)]])
    -> ([(Int, Lr0Item, NameSet)] -> [((Int, Lr0Item), NameSet)])
    -> [(Int, Lr0Item, NameSet)]
    -> [[((Int, Lr0Item), NameSet)]]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
    >     (((Int, Lr0Item), NameSet)
     -> ((Int, Lr0Item), NameSet) -> Ordering)
    -> [((Int, Lr0Item), NameSet)] -> [((Int, Lr0Item), NameSet)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy ((Int, Lr0Item) -> (Int, Lr0Item) -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare ((Int, Lr0Item) -> (Int, Lr0Item) -> Ordering)
    -> (((Int, Lr0Item), NameSet) -> (Int, Lr0Item))
    -> ((Int, Lr0Item), NameSet)
    -> ((Int, Lr0Item), NameSet)
    -> Ordering
    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
    `on` ((Int, Lr0Item), NameSet) -> (Int, Lr0Item)
    forall a b. (a, b) -> a
    fst) ([((Int, Lr0Item), NameSet)] -> [((Int, Lr0Item), NameSet)])
    -> ([(Int, Lr0Item, NameSet)] -> [((Int, Lr0Item), NameSet)])
    -> [(Int, Lr0Item, NameSet)]
    -> [((Int, Lr0Item), NameSet)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
    >     ((Int, Lr0Item, NameSet) -> ((Int, Lr0Item), NameSet))
    -> [(Int, Lr0Item, NameSet)] -> [((Int, Lr0Item), NameSet)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Int
    a,Lr0Item
    b,NameSet
    c) -> ((Int
    a,Lr0Item
    b),NameSet
    c))

    -----------------------------------------------------------------------------
    Merge lookaheads

    > -- TODO needs better name
    > type Lr1State = ([Lr1Item], [(Name, Int)])

    Stick the lookahead info back into the state table.

    > mergeLookaheadInfo
    >       :: Array Int [(Lr0Item, NameSet)]       -- ^ lookahead info
    >       -> [ItemSetWithGotos]                   -- ^ state table
    >       -> [Lr1State]

    > mergeLookaheadInfo :: Array Int [(Lr0Item, NameSet)] -> [ItemSetWithGotos] -> [Lr1State]
    mergeLookaheadInfo Array Int [(Lr0Item, NameSet)]
    lookaheads [ItemSetWithGotos]
    sets
    >       = (ItemSetWithGotos -> Int -> Lr1State)
    -> [ItemSetWithGotos] -> [Int] -> [Lr1State]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith ItemSetWithGotos -> Int -> Lr1State
    mergeIntoSet [ItemSetWithGotos]
    sets [Int
    0..]
    >       where

    >         mergeIntoSet :: ItemSetWithGotos -> Int -> Lr1State
    >         mergeIntoSet :: ItemSetWithGotos -> Int -> Lr1State
    mergeIntoSet (Set Lr0Item
    items, [(Name, Int)]
    goto) Int
    i
    >               = ((Lr0Item -> Lr1Item) -> [Lr0Item] -> [Lr1Item]
    forall a b. (a -> b) -> [a] -> [b]
    map Lr0Item -> Lr1Item
    mergeIntoItem (Set Lr0Item -> [Lr0Item]
    forall a. Set a -> [a]
    Set.toAscList Set Lr0Item
    items), [(Name, Int)]
    goto)
    >               where

    >                 mergeIntoItem :: Lr0Item -> Lr1Item
    >                 mergeIntoItem :: Lr0Item -> Lr1Item
    mergeIntoItem item :: Lr0Item
    item@(Lr0 Int
    rule Int
    dot) = Int -> Int -> NameSet -> Lr1Item
    Lr1 Int
    rule Int
    dot NameSet
    la
    >                    where la :: NameSet
    la = case [ NameSet
    s | (Lr0Item
    item',NameSet
    s) <- Array Int [(Lr0Item, NameSet)]
    lookaheads Array Int [(Lr0Item, NameSet)] -> Int -> [(Lr0Item, NameSet)]
    forall i e. Ix i => Array i e -> i -> e
    ! Int
    i,
    >                                           Lr0Item
    item Lr0Item -> Lr0Item -> Bool
    forall a. Eq a => a -> a -> Bool
    == Lr0Item
    item' ] of
    >                                       [] -> NameSet
    NameSet.empty
    >                                       [NameSet
    x] -> NameSet
    x
    >                                       [NameSet]
    _ -> String -> NameSet
    forall a. HasCallStack => String -> a
    error String
    "mergIntoItem"

    -----------------------------------------------------------------------------
    Generate the goto table

    This is pretty straightforward, given all the information we stored
    while generating the LR0 sets of items.

    Generating the goto table doesn't need lookahead info.

    > genGotoTable :: Grammar e -> [ItemSetWithGotos] -> GotoTable
    > genGotoTable :: forall e. Grammar e -> [ItemSetWithGotos] -> GotoTable
    genGotoTable Grammar e
    g [ItemSetWithGotos]
    sets = GotoTable
    gotoTable
    >   where
    >       Grammar{ first_nonterm :: forall eliminator. Grammar eliminator -> Name
    first_nonterm = Name
    fst_nonterm,
    >                first_term :: forall eliminator. Grammar eliminator -> Name
    first_term    = Name
    fst_term,
    >                non_terminals :: forall eliminator. Grammar eliminator -> [Name]
    non_terminals = [Name]
    non_terms } = Grammar e
    g
    >
    >       -- goto array doesn't include %start symbols
    >       gotoTable :: GotoTable
    gotoTable  = (Int, Int) -> [Array Name Goto] -> GotoTable
    forall i e. Ix i => (i, i) -> [e] -> Array i e
    listArray (Int
    0,[ItemSetWithGotos] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [ItemSetWithGotos]
    setsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)
    >         [
    >           ((Name, Name) -> [(Name, Goto)] -> Array Name Goto
    forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
    array (Name
    fst_nonterm, Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Int
    getName Name
    fst_term Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) [
    >               (Name
    n, Goto -> (Int -> Goto) -> Maybe Int -> Goto
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Goto
    NoGoto Int -> Goto
    Goto (Name -> [(Name, Int)] -> Maybe Int
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    n [(Name, Int)]
    goto))
    >                             | Name
    n <- [Name]
    non_terms,
    >                               Name
    n Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Name
    fst_nonterm, Name
    n Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    < Name
    fst_term ])
    >                 | (Set Lr0Item
    _set,[(Name, Int)]
    goto) <- [ItemSetWithGotos]
    sets  ]

    -----------------------------------------------------------------------------
    Generate the action table

    > genActionTable :: Grammar e -> ([Name] -> NameSet) ->
    >                [Lr1State] -> ActionTable
    > genActionTable :: forall e.
    Grammar e -> ([Name] -> NameSet) -> [Lr1State] -> ActionTable
    genActionTable Grammar e
    g [Name] -> NameSet
    first [Lr1State]
    sets = ActionTable
    actionTable
    >   where
    >       Grammar { first_term :: forall eliminator. Grammar eliminator -> Name
    first_term = Name
    fst_term,
    >                 terminals :: forall eliminator. Grammar eliminator -> [Name]
    terminals = [Name]
    terms,
    >                 starts :: forall eliminator.
    Grammar eliminator -> [(String, Name, Name, Bool)]
    starts = [(String, Name, Name, Bool)]
    starts',
    >                 priorities :: forall eliminator. Grammar eliminator -> [(Name, Priority)]
    priorities = [(Name, Priority)]
    prios } = Grammar e
    g

    >       n_starts :: Int
    n_starts = [(String, Name, Name, Bool)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(String, Name, Name, Bool)]
    starts'
    >       isStartRule :: Int -> Bool
    isStartRule Int
    rule = Int
    rule Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    n_starts -- a bit hacky, but it'll do for now

    >       term_lim :: (Name, Name)
    term_lim = ([Name] -> Name
    forall a. HasCallStack => [a] -> a
    head [Name]
    terms,[Name] -> Name
    forall a. HasCallStack => [a] -> a
    last [Name]
    terms)
    >       actionTable :: ActionTable
    actionTable = (Int, Int) -> [(Int, Array Name LRAction)] -> ActionTable
    forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
    array (Int
    0,[Lr1State] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Lr1State]
    setsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)
    >             [ (Int
    set_no, (LRAction -> LRAction -> LRAction)
    -> LRAction
    -> (Name, Name)
    -> [(Name, LRAction)]
    -> Array Name LRAction
    forall i e a.
    Ix i =>
    (e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
    accumArray LRAction -> LRAction -> LRAction
    res
    >                                LRAction
    LR'Fail (Name, Name)
    term_lim
    >                               ([(Name, Int)] -> [Lr1Item] -> [(Name, LRAction)]
    possActions [(Name, Int)]
    goto [Lr1Item]
    set))
    >                   | (([Lr1Item]
    set,[(Name, Int)]
    goto),Int
    set_no) <- [Lr1State] -> [Int] -> [(Lr1State, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Lr1State]
    sets [Int
    0..] ]

    >       possAction :: [(Name, Int)] -> p -> Lr1Item -> [(Name, LRAction)]
    possAction [(Name, Int)]
    goto p
    _set (Lr1 Int
    rule Int
    pos NameSet
    la) =
    >          case Grammar e -> Int -> Int -> Maybe Name
    forall e. Grammar e -> Int -> Int -> Maybe Name
    findRule Grammar e
    g Int
    rule Int
    pos of
    >               Just Name
    t | Name
    t Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Name
    fst_term Bool -> Bool -> Bool
    || Name
    t Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    errorTok Bool -> Bool -> Bool
    || Name
    t Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    catchTok ->
    >                       let f :: Int -> (Name, LRAction)
    f Int
    j = (Name
    t,Int -> Priority -> LRAction
    LR'Shift Int
    j Priority
    p)
    >                           p :: Priority
    p = Priority -> (Priority -> Priority) -> Maybe Priority -> Priority
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Priority
    No Priority -> Priority
    forall a. a -> a
    id (Name -> [(Name, Priority)] -> Maybe Priority
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    t [(Name, Priority)]
    prios)
    >                       in (Int -> (Name, LRAction)) -> [Int] -> [(Name, LRAction)]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> (Name, LRAction)
    f ([Int] -> [(Name, LRAction)]) -> [Int] -> [(Name, LRAction)]
    forall a b. (a -> b) -> a -> b
    $ Maybe Int -> [Int]
    forall a. Maybe a -> [a]
    maybeToList (Name -> [(Name, Int)] -> Maybe Int
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    t [(Name, Int)]
    goto)
    >               Maybe Name
    Nothing
    >                  | Int -> Bool
    isStartRule Int
    rule
    >                  -> let (String
    _,Name
    _,Name
    _,Bool
    partial) = [(String, Name, Name, Bool)]
    starts' [(String, Name, Name, Bool)] -> Int -> (String, Name, Name, Bool)
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    rule in
    >                     [ (Grammar e -> Bool -> Name
    forall e. Grammar e -> Bool -> Name
    startLookahead Grammar e
    g Bool
    partial, LRAction
    LR'Accept{-'-}) ]
    >                  | Bool
    otherwise
    >                  -> let Production Name
    _ [Name]
    _ (e, [Int])
    _ Priority
    p = Grammar e -> Int -> Production e
    forall eliminator.
    Grammar eliminator -> Int -> Production eliminator
    lookupProdNo Grammar e
    g Int
    rule in
    >                     NameSet -> [Name]
    NameSet.toAscList NameSet
    la [Name] -> [LRAction] -> [(Name, LRAction)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` LRAction -> [LRAction]
    forall a. a -> [a]
    repeat (Int -> Priority -> LRAction
    LR'Reduce Int
    rule Priority
    p)
    >               Maybe Name
    _ -> []

    >       possActions :: [(Name, Int)] -> [Lr1Item] -> [(Name, LRAction)]
    possActions [(Name, Int)]
    goto [Lr1Item]
    coll = do item <- Grammar e -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
    forall e.
    Grammar e -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
    closure1 Grammar e
    g [Name] -> NameSet
    first [Lr1Item]
    coll
    >                                  possAction goto coll item

    These comments are now out of date! /JS

    Here's how we resolve conflicts, leaving a complete record of the
    conflicting actions in an LR'Multiple structure for later output in
    the info file.

    Shift/reduce conflicts are always resolved as shift actions, and
    reduce/reduce conflicts are resolved as a reduce action using the rule
    with the lowest number (i.e. the rule that comes first in the grammar
    file.)

    NOTES on LR'MustFail: this was introduced as part of the precedence
    parsing changes.  The problem with LR'Fail is that it is a soft
    failure: we sometimes substitute an LR'Fail for an LR'Reduce (eg. when
    computing default actions), on the grounds that an LR'Fail in this
    state will also be an LR'Fail in the goto state, so we'll fail
    eventually.  This may not be true with precedence parsing, though.  If
    there are two non-associative operators together, we must fail at this
    point rather than reducing.  Hence the use of LR'MustFail.

    NOTE: on (LR'Multiple as a) handling
          PCC [sep04] has changed this to have the following invariants:
            * the winning action appears only once, in the "a" slot
            * only reductions appear in the "as" list
            * there are no duplications
          This removes complications elsewhere, where LR'Multiples were
          building up tree structures...

    >       res :: LRAction -> LRAction -> LRAction
    res LRAction
    LR'Fail LRAction
    x = LRAction
    x
    >       res LRAction
    x LRAction
    LR'Fail = LRAction
    x
    >       res LRAction
    LR'MustFail LRAction
    _ = LRAction
    LR'MustFail
    >       res LRAction
    _ LRAction
    LR'MustFail = LRAction
    LR'MustFail
    >       res LRAction
    x LRAction
    x' | LRAction
    x LRAction -> LRAction -> Bool
    forall a. Eq a => a -> a -> Bool
    == LRAction
    x' = LRAction
    x
    >       res (LRAction
    LR'Accept) LRAction
    _ = LRAction
    LR'Accept
    >       res LRAction
    _ (LRAction
    LR'Accept) = LRAction
    LR'Accept

    >       res (LR'Multiple [LRAction]
    as LRAction
    x) (LR'Multiple [LRAction]
    bs LRAction
    x')
    >        | LRAction
    x LRAction -> LRAction -> Bool
    forall a. Eq a => a -> a -> Bool
    == LRAction
    x' = [LRAction] -> LRAction -> LRAction
    LR'Multiple ([LRAction] -> [LRAction]
    forall a. Eq a => [a] -> [a]
    nub ([LRAction] -> [LRAction]) -> [LRAction] -> [LRAction]
    forall a b. (a -> b) -> a -> b
    $ [LRAction]
    as [LRAction] -> [LRAction] -> [LRAction]
    forall a. [a] -> [a] -> [a]
    ++ [LRAction]
    bs) LRAction
    x
    >               -- merge dropped reductions for identical action

    >        | Bool
    otherwise
    >              = case LRAction -> LRAction -> LRAction
    res LRAction
    x LRAction
    x' of
    >                  LR'Multiple [LRAction]
    cs LRAction
    a
    >                    | LRAction
    a LRAction -> LRAction -> Bool
    forall a. Eq a => a -> a -> Bool
    == LRAction
    x    -> [LRAction] -> LRAction -> LRAction
    LR'Multiple ([LRAction] -> [LRAction]
    forall a. Eq a => [a] -> [a]
    nub ([LRAction] -> [LRAction]) -> [LRAction] -> [LRAction]
    forall a b. (a -> b) -> a -> b
    $ LRAction
    x' LRAction -> [LRAction] -> [LRAction]
    forall a. a -> [a] -> [a]
    : [LRAction]
    as [LRAction] -> [LRAction] -> [LRAction]
    forall a. [a] -> [a] -> [a]
    ++ [LRAction]
    bs [LRAction] -> [LRAction] -> [LRAction]
    forall a. [a] -> [a] -> [a]
    ++ [LRAction]
    cs) LRAction
    x
    >                    | LRAction
    a LRAction -> LRAction -> Bool
    forall a. Eq a => a -> a -> Bool
    == LRAction
    x'   -> [LRAction] -> LRAction -> LRAction
    LR'Multiple ([LRAction] -> [LRAction]
    forall a. Eq a => [a] -> [a]
    nub ([LRAction] -> [LRAction]) -> [LRAction] -> [LRAction]
    forall a b. (a -> b) -> a -> b
    $ LRAction
    x  LRAction -> [LRAction] -> [LRAction]
    forall a. a -> [a] -> [a]
    : [LRAction]
    as [LRAction] -> [LRAction] -> [LRAction]
    forall a. [a] -> [a] -> [a]
    ++ [LRAction]
    bs [LRAction] -> [LRAction] -> [LRAction]
    forall a. [a] -> [a] -> [a]
    ++ [LRAction]
    cs) LRAction
    x'
    >                    | Bool
    otherwise -> String -> LRAction
    forall a. HasCallStack => String -> a
    error String
    "failed invariant in resolve"
    >                               -- last means an unexpected change
    >                  LRAction
    other -> LRAction
    other
    >               -- merge dropped reductions for clashing actions, but only
    >               -- if they were S/R or R/R

    >       res a :: LRAction
    a@(LR'Multiple [LRAction]
    _ LRAction
    _) LRAction
    b = LRAction -> LRAction -> LRAction
    res LRAction
    a ([LRAction] -> LRAction -> LRAction
    LR'Multiple [] LRAction
    b)
    >       res LRAction
    a b :: LRAction
    b@(LR'Multiple [LRAction]
    _ LRAction
    _) = LRAction -> LRAction -> LRAction
    res ([LRAction] -> LRAction -> LRAction
    LR'Multiple [] LRAction
    a) LRAction
    b
    >         -- leave cases above to do the appropriate merging

    >       res a :: LRAction
    a@(LR'Shift {}) b :: LRAction
    b@(LR'Reduce {}) = LRAction -> LRAction -> LRAction
    res LRAction
    b LRAction
    a
    >       res a :: LRAction
    a@(LR'Reduce Int
    _ Priority
    p) b :: LRAction
    b@(LR'Shift Int
    _ Priority
    p')
    >               = case (Priority
    p,Priority
    p') of
    >                      (Priority
    PrioLowest,Priority
    PrioLowest) -> LRAction
    LR'MustFail
    >                      (Priority
    _,Priority
    PrioLowest) -> LRAction
    a
    >                      (Priority
    PrioLowest,Priority
    _) -> LRAction
    b
    >                      (Priority
    No,Priority
    _) -> [LRAction] -> LRAction -> LRAction
    LR'Multiple [LRAction
    a] LRAction
    b      -- shift wins
    >                      (Priority
    _,Priority
    No) -> [LRAction] -> LRAction -> LRAction
    LR'Multiple [LRAction
    a] LRAction
    b      -- shift wins
    >                      (Prio Assoc
    c Int
    i, Prio Assoc
    _ Int
    j)
    >                               | Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    j     -> LRAction
    b
    >                               | Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    j     -> LRAction
    a
    >                               | Bool
    otherwise ->
    >                                  case Assoc
    c of
    >                                     Assoc
    LeftAssoc  -> LRAction
    a
    >                                     Assoc
    RightAssoc -> LRAction
    b
    >                                     Assoc
    None       -> LRAction
    LR'MustFail
    >       res a :: LRAction
    a@(LR'Reduce Int
    r Priority
    p) b :: LRAction
    b@(LR'Reduce Int
    r' Priority
    p')
    >               = case (Priority
    p,Priority
    p') of
    >                      (Priority
    PrioLowest,Priority
    PrioLowest) ->
    >                        [LRAction] -> LRAction -> LRAction
    LR'Multiple [LRAction
    a] LRAction
    b      -- give to earlier rule?
    >                      (Priority
    _,Priority
    PrioLowest) -> LRAction
    a
    >                      (Priority
    PrioLowest,Priority
    _) -> LRAction
    b
    >                      (Priority
    No,Priority
    _) -> [LRAction] -> LRAction -> LRAction
    LR'Multiple [LRAction
    a] LRAction
    b      -- give to earlier rule?
    >                      (Priority
    _,Priority
    No) -> [LRAction] -> LRAction -> LRAction
    LR'Multiple [LRAction
    a] LRAction
    b
    >                      (Prio Assoc
    _ Int
    i, Prio Assoc
    _ Int
    j)
    >                               | Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    j     -> LRAction
    b
    >                               | Int
    j Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    i     -> LRAction
    a
    >                               | Int
    r Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    r'    -> [LRAction] -> LRAction -> LRAction
    LR'Multiple [LRAction
    b] LRAction
    a
    >                               | Bool
    otherwise -> [LRAction] -> LRAction -> LRAction
    LR'Multiple [LRAction
    a] LRAction
    b
    >       res LRAction
    _ LRAction
    _ = String -> LRAction
    forall a. HasCallStack => String -> a
    error String
    "conflict in resolve"

    -----------------------------------------------------------------------------
    Count the conflicts

    > countConflicts :: ActionTable -> (Array Int (Int,Int), (Int,Int))
    > countConflicts :: ActionTable -> (Array Int (Int, Int), (Int, Int))
    countConflicts ActionTable
    action
    >   = (Array Int (Int, Int)
    conflictArray, ((Int, Int) -> (Int, Int) -> (Int, Int))
    -> (Int, Int) -> [(Int, Int)] -> (Int, Int)
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\(Int
    a,Int
    b) (Int
    c,Int
    d) -> let ac :: Int
    ac = Int
    a Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    c; bd :: Int
    bd = Int
    b Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    d in Int
    ac Int -> (Int, Int) -> (Int, Int)
    forall a b. a -> b -> b
    `seq` Int
    bd Int -> (Int, Int) -> (Int, Int)
    forall a b. a -> b -> b
    `seq` (Int
    ac,Int
    bd)) (Int
    0,Int
    0) [(Int, Int)]
    conflictList)
    >
    >   where
    >
    >       conflictArray :: Array Int (Int, Int)
    conflictArray = (Int, Int) -> [(Int, Int)] -> Array Int (Int, Int)
    forall i e. Ix i => (i, i) -> [e] -> Array i e
    listArray (ActionTable -> (Int, Int)
    forall i e. Array i e -> (i, i)
    Array.bounds ActionTable
    action) [(Int, Int)]
    conflictList
    >       conflictList :: [(Int, Int)]
    conflictList  = ((Int, Array Name LRAction) -> (Int, Int))
    -> [(Int, Array Name LRAction)] -> [(Int, Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, Array Name LRAction) -> (Int, Int)
    forall {a} {b} {a} {i}.
    (Num a, Num b) =>
    (a, Array i LRAction) -> (a, b)
    countConflictsState (ActionTable -> [(Int, Array Name LRAction)]
    forall i e. Ix i => Array i e -> [(i, e)]
    assocs ActionTable
    action)
    >
    >       countConflictsState :: (a, Array i LRAction) -> (a, b)
    countConflictsState (a
    _state, Array i LRAction
    actions)
    >         = (LRAction -> (a, b) -> (a, b)) -> (a, b) -> [LRAction] -> (a, b)
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr LRAction -> (a, b) -> (a, b)
    forall {a} {b}. (Num a, Num b) => LRAction -> (a, b) -> (a, b)
    countMultiples (a
    0,b
    0) (Array i LRAction -> [LRAction]
    forall i e. Array i e -> [e]
    elems Array i LRAction
    actions)
    >         where
    >           countMultiples :: LRAction -> (a, b) -> (a, b)
    countMultiples (LR'Multiple (LRAction
    _:[LRAction]
    _) (LR'Shift{})) (a
    sr,b
    rr)
    >               = (a
    sr a -> a -> a
    forall a. Num a => a -> a -> a
    + a
    1, b
    rr)
    >           countMultiples (LR'Multiple (LRAction
    _:[LRAction]
    _) (LR'Reduce{})) (a
    sr,b
    rr)
    >               = (a
    sr, b
    rr b -> b -> b
    forall a. Num a => a -> a -> a
    + b
    1)
    >           countMultiples (LR'Multiple [LRAction]
    _ LRAction
    _) (a, b)
    _
    >               = String -> (a, b)
    forall a. HasCallStack => String -> a
    error String
    "bad conflict representation"
    >           countMultiples LRAction
    _ (a, b)
    c = (a, b)
    c

    -----------------------------------------------------------------------------

    > findRule :: Grammar e -> Int -> Int -> Maybe Name
    > findRule :: forall e. Grammar e -> Int -> Int -> Maybe Name
    findRule Grammar e
    g Int
    rule Int
    dot = [Name] -> Maybe Name
    forall a. [a] -> Maybe a
    listToMaybe (Int -> [Name] -> [Name]
    forall a. Int -> [a] -> [a]
    drop Int
    dot [Name]
    lhs)
    >     where Production Name
    _ [Name]
    lhs (e, [Int])
    _ Priority
    _ = Grammar e -> Int -> Production e
    forall eliminator.
    Grammar eliminator -> Int -> Production eliminator
    lookupProdNo Grammar e
    g Int
    rule