-----------------------------------------------------------------------------
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 Int
rule' Int
dot' NameSet
ts) <- [Lr1Item]
j
>                   let ts' :: NameSet
ts' = Name -> NameSet -> NameSet
NameSet.delete Name
dummyTok NameSet
ts
>                   Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ NameSet -> Bool
NameSet.null NameSet
ts')
>                   Maybe (Int, Lr0Item, NameSet) -> [(Int, Lr0Item, NameSet)]
forall a. Maybe a -> [a]
maybeToList (Maybe (Int, Lr0Item, NameSet) -> [(Int, Lr0Item, NameSet)])
-> Maybe (Int, Lr0Item, NameSet) -> [(Int, Lr0Item, NameSet)]
forall a b. (a -> b) -> a -> b
$ do Name
r <- Grammar e -> Int -> Int -> Maybe Name
forall e. Grammar e -> Int -> Int -> Maybe Name
findRule Grammar e
gram Int
rule' Int
dot'
>                                    (Int, Lr0Item, NameSet) -> Maybe (Int, Lr0Item, NameSet)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ( String -> Name -> Int
lookupGoto String
"spontaneous" Name
r
>                                           , Int -> Int -> Lr0Item
Lr0 Int
rule' (Int
dot' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
>                                           , NameSet
ts' )

>               propagated :: [(Lr0Item, Int, Lr0Item)]
>               propagated :: [(Lr0Item, Int, Lr0Item)]
propagated = do
>                   (Lr1 Int
rule' Int
dot' NameSet
ts) <- [Lr1Item]
j
>                   Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Name -> NameSet -> Bool
NameSet.member Name
dummyTok NameSet
ts
>                   Maybe (Lr0Item, Int, Lr0Item) -> [(Lr0Item, Int, Lr0Item)]
forall a. Maybe a -> [a]
maybeToList (Maybe (Lr0Item, Int, Lr0Item) -> [(Lr0Item, Int, Lr0Item)])
-> Maybe (Lr0Item, Int, Lr0Item) -> [(Lr0Item, Int, Lr0Item)]
forall a b. (a -> b) -> a -> b
$ do Name
r <- Grammar e -> Int -> Int -> Maybe Name
forall e. Grammar e -> Int -> Int -> Maybe Name
findRule Grammar e
gram Int
rule' Int
dot'
>                                    (Lr0Item, Int, Lr0Item) -> Maybe (Lr0Item, Int, Lr0Item)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Lr0Item
item
>                                           , String -> Name -> Int
lookupGoto String
"propagated" Name
r
>                                           , Int -> Int -> Lr0Item
Lr0 Int
rule' (Int
dot' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
>           STArray s Int [(Lr0Item, NameSet)]
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) []
>           STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
forall s.
STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
propagate STArray s Int [(Lr0Item, NameSet)]
arr ([(Int, Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)]
fold_lookahead [(Int, Lr0Item, NameSet)]
spont)
>           STArray s Int [(Lr0Item, NameSet)]
-> ST s (Array Int [(Lr0Item, NameSet)])
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
freeze STArray s Int [(Lr0Item, NameSet)]
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' ]
>               [(Int, Lr0Item, NameSet)]
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 []
>               STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
forall s.
STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
add_lookaheads STArray s Int [(Lr0Item, NameSet)]
arr [(Int, Lr0Item, NameSet)]
new
>               STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
forall s.
STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
propagate STArray s Int [(Lr0Item, NameSet)]
arr [(Int, Lr0Item, NameSet)]
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 [(Lr0Item, NameSet)]
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
>                          STArray s Int [(Lr0Item, NameSet)]
-> Int -> [(Lr0Item, NameSet)] -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int [(Lr0Item, NameSet)]
arr Int
i (Lr0Item -> NameSet -> [(Lr0Item, NameSet)] -> [(Lr0Item, NameSet)]
add_lookahead Lr0Item
item NameSet
s [(Lr0Item, NameSet)]
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
>       [(Lr0Item, NameSet)]
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
>       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)]
las ((Int, Lr0Item, NameSet)
-> [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)]
get_new' (Int, Lr0Item, NameSet)
l [(Lr0Item, NameSet)]
state_las [(Int, Lr0Item, NameSet)]
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 Lr1Item
item <- Grammar e -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
forall e.
Grammar e -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
closure1 Grammar e
g [Name] -> NameSet
first [Lr1Item]
coll
>                                  [(Name, Int)] -> [Lr1Item] -> Lr1Item -> [(Name, LRAction)]
forall {p}. [(Name, Int)] -> p -> Lr1Item -> [(Name, LRAction)]
possAction [(Name, Int)]
goto [Lr1Item]
coll Lr1Item
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