> module LALR
>	(genActionTable, genGotoTable, genLR0items, precalcClosure0,
>	 propLookaheads, calcLookaheads, mergeLookaheadInfo, countConflicts,
>	 Lr0Item(..), Lr1Item)
>	where


> import GenUtils
> import Data.Set ( Set )
> import qualified Data.Set as Set hiding ( Set )
> import qualified NameSet
> import NameSet ( NameSet )
> import Grammar


> import Control.Monad.ST
> import Data.Array.ST
> import Data.Array as Array
> import Data.List (nub)


> 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 = forall a b. (a -> b -> b) -> b -> Set a -> b
Set.fold (forall a. Ord a => Set a -> Set a -> Set a
Set.union forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set b
f) forall a. Set a
Set.empty


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






> data Lr0Item = Lr0 {-#UNPACK#-}!Int {-#UNPACK#-}!Int			-- (rule, dot)
>       deriving (Lr0Item -> Lr0Item -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lr0Item -> Lr0Item -> Bool
$c/= :: Lr0Item -> Lr0Item -> Bool
== :: Lr0Item -> Lr0Item -> Bool
$c== :: Lr0Item -> Lr0Item -> Bool
Eq,Eq 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
min :: Lr0Item -> Lr0Item -> Lr0Item
$cmin :: Lr0Item -> Lr0Item -> Lr0Item
max :: Lr0Item -> Lr0Item -> Lr0Item
$cmax :: Lr0Item -> Lr0Item -> Lr0Item
>= :: Lr0Item -> Lr0Item -> Bool
$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
compare :: Lr0Item -> Lr0Item -> Ordering
$ccompare :: Lr0Item -> Lr0Item -> Ordering
Ord)


> data Lr1Item = Lr1 {-#UNPACK#-}!Int {-#UNPACK#-}!Int NameSet  -- (rule, dot, lookahead)
> type RuleList = [Lr0Item]














> precalcClosure0 :: Grammar -> Name -> RuleList
> precalcClosure0 :: Grammar -> Int -> RuleList
precalcClosure0 Grammar
g = 
>	\Int
n -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
n [(Int, RuleList)]
info' of
>		Maybe RuleList
Nothing -> []
>		Just RuleList
c  -> RuleList
c
>  where
>
>	info' :: [(Name, RuleList)]
>	info' :: [(Int, RuleList)]
info' = forall a b. (a -> b) -> [a] -> [b]
map (\(Int
n,NameSet
rules) -> (Int
n,forall a b. (a -> b) -> [a] -> [b]
map (\Int
rule -> Int -> Int -> Lr0Item
Lr0 Int
rule Int
0) (NameSet -> [Int]
NameSet.toAscList NameSet
rules))) [(Int, NameSet)]
info


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


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


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


>	nts :: [Int]
nts = Grammar -> [Int]
non_terminals Grammar
g
>	fst_term :: Int
fst_term = Grammar -> Int
first_term Grammar
g


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








> closure1 :: Grammar -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]
> closure1 :: Grammar -> ([Int] -> NameSet) -> [Lr1Item] -> [Lr1Item]
closure1 Grammar
g [Int] -> NameSet
first [Lr1Item]
set
>       = forall a b. (a, b) -> a
fst (forall a. (a -> a -> Bool) -> (a -> a) -> a -> a
mkClosure (\([Lr1Item]
_,[Lr1Item]
new) ([Lr1Item], [Lr1Item])
_ -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Lr1Item]
new) ([Lr1Item], [Lr1Item]) -> ([Lr1Item], [Lr1Item])
addItems ([],[Lr1Item]
set))
>	where
>	fst_term :: Int
fst_term = Grammar -> Int
first_term Grammar
g


>	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 
>				   (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Lr1Item] -> [Lr1Item] -> [Lr1Item]
union_items [] (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 Grammar -> Int -> Production
lookupProdNo Grammar
g Int
rule of { (Int
_name,[Int]
lhs,([Char], [Int])
_,Priority
_) ->
>		    case forall a. Int -> [a] -> [a]
drop Int
dot [Int]
lhs of
>			(Int
b:[Int]
beta) | Int
b forall a. Ord a => a -> a -> Bool
>= Int
firstStartTok Bool -> Bool -> Bool
&& Int
b forall a. Ord a => a -> a -> Bool
< Int
fst_term ->
>			    let terms :: NameSet
terms = (Int -> NameSet) -> NameSet -> NameSet
unionNameMap 
>						(\Int
a -> [Int] -> NameSet
first ([Int]
beta forall a. [a] -> [a] -> [a]
++ [Int
a])) NameSet
as
>			    in
>			    [ (Int -> Int -> NameSet -> Lr1Item
Lr1 Int
rule' Int
0 NameSet
terms) | Int
rule' <- Grammar -> Int -> [Int]
lookupProdsOfName Grammar
g Int
b ]
>			[Int]
_ -> []
>		    }






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










> subtract_item :: [Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item]
> subtract_item :: [Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item]
subtract_item [] Lr1Item
i [Lr1Item]
result = Lr1Item
i 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 forall a. Ord a => a -> a -> Ordering
compare Int
rule' Int
rule of
>		Ordering
LT -> Lr1Item
i forall a. a -> [a] -> [a]
: [Lr1Item]
result
>		Ordering
GT -> [Lr1Item]
carry_on
>		Ordering
EQ -> case forall a. Ord a => a -> a -> Ordering
compare Int
dot' Int
dot of
>			Ordering
LT -> Lr1Item
i 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) 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_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 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 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')) forall a. a -> [a] -> [a]
: [Lr1Item] -> [Lr1Item] -> [Lr1Item]
union_items [Lr1Item]
is [Lr1Item]
is'
>  where
>	drop_i :: [Lr1Item]
drop_i  = Lr1Item
i  forall a. a -> [a] -> [a]
: [Lr1Item] -> [Lr1Item] -> [Lr1Item]
union_items [Lr1Item]
is (Lr1Item
i'forall a. a -> [a] -> [a]
:[Lr1Item]
is')
>	drop_i' :: [Lr1Item]
drop_i' = Lr1Item
i' forall a. a -> [a] -> [a]
: [Lr1Item] -> [Lr1Item] -> [Lr1Item]
union_items (Lr1Item
iforall a. a -> [a] -> [a]
:[Lr1Item]
is) [Lr1Item]
is'
















> gotoClosure :: Grammar -> Set Lr0Item -> Name -> Set Lr0Item
> gotoClosure :: Grammar -> Set Lr0Item -> Int -> Set Lr0Item
gotoClosure Grammar
gram Set Lr0Item
i Int
x = 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 -> Int -> Int -> Maybe Int
findRule Grammar
gram Int
rule_no Int
dot of
>               Just Int
t | Int
x forall a. Eq a => a -> a -> Bool
== Int
t -> forall a. a -> Set a
Set.singleton (Int -> Int -> Lr0Item
Lr0 Int
rule_no (Int
dotforall a. Num a => a -> a -> a
+Int
1))
>               Maybe Int
_ -> forall a. Set a
Set.empty           
























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


> genLR0items :: Grammar -> (Name -> RuleList) -> [ItemSetWithGotos]
> genLR0items :: Grammar -> (Int -> RuleList) -> [ItemSetWithGotos]
genLR0items Grammar
g Int -> RuleList
precalcClosures
>	= forall a b. (a, b) -> a
fst (forall a. (a -> a -> Bool) -> (a -> a) -> a -> a
mkClosure (\([ItemSetWithGotos]
_old,[Set Lr0Item]
new) ([ItemSetWithGotos], [Set Lr0Item])
_ -> 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length (Grammar -> [([Char], Int, Int, Bool)]
starts Grammar
g)
>    startRules :: [Set Lr0Item]
>    startRules :: [Set Lr0Item]
startRules = [ forall a. a -> Set a
Set.singleton (Int -> Int -> Lr0Item
Lr0 Int
rule Int
0) | Int
rule <- [Int
0..Int
n_starts] ]


>    tokens :: [Int]
tokens = Grammar -> [Int]
non_terminals Grammar
g forall a. [a] -> [a] -> [a]
++ Grammar -> [Int]
terminals Grammar
g


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


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








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










































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






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


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














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


> propLookaheads :: Grammar
-> [ItemSetWithGotos]
-> ([Int] -> NameSet)
-> ([(Int, Lr0Item, NameSet)], Array Int [(Lr0Item, Int, Lr0Item)])
propLookaheads Grammar
gram [ItemSetWithGotos]
sets [Int] -> NameSet
first = (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Lr0Item, NameSet)]]
s, forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,forall (t :: * -> *) a. Foldable t => t a -> Int
length [ItemSetWithGotos]
sets 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) = forall a b. [(a, b)] -> ([a], [b])
unzip (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,[(Int, Int)]
goto) Int
i = ([(Int, Lr0Item, NameSet)]
start_spont forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Lr0Item, NameSet)]]
s', (Int
i, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Lr0Item, Int, Lr0Item)]]
p'))
>	where


>	  ([[(Int, Lr0Item, NameSet)]]
s',[[(Lr0Item, Int, Lr0Item)]]
p') = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)])
propLAItem (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 :: [([Char], Int, Int, Bool)]
start_info = Grammar -> [([Char], Int, Int, Bool)]
starts Grammar
gram	


>	  start_spont :: [(Int, Lr0Item ,NameSet)]
>	  start_spont :: [(Int, Lr0Item, NameSet)]
start_spont	= [ (Int
start, (Int -> Int -> Lr0Item
Lr0 Int
start Int
0), 
>			     Int -> NameSet
NameSet.singleton (Grammar -> Bool -> Int
startLookahead Grammar
gram Bool
partial))
>			  | (Int
start, ([Char]
_,Int
_,Int
_,Bool
partial)) <- 
>				forall a b. [a] -> [b] -> [(a, b)]
zip [ Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Char], Int, Int, Bool)]
start_info forall a. Num a => a -> a -> a
- Int
1] [([Char], Int, Int, 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


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


>		spontaneous :: [(Int, Lr0Item, NameSet)]
>		spontaneous :: [(Int, Lr0Item, NameSet)]
spontaneous = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ 
>		 (case Grammar -> Int -> Int -> Maybe Int
findRule Grammar
gram Int
rule' Int
dot' of
>		     Maybe Int
Nothing -> []
>		     Just Int
x  -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
x [(Int, Int)]
goto of
>			 	  Maybe Int
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"spontaneous"
>				  Just Int
k  ->
>					case (Int -> Bool) -> NameSet -> NameSet
NameSet.filter (forall a. Eq a => a -> a -> Bool
/= Int
dummyTok) NameSet
ts of
>					   NameSet
ts' | NameSet -> Bool
NameSet.null NameSet
ts' -> []
>					       | Bool
otherwise -> [(Int
k, Int -> Int -> Lr0Item
Lr0 Int
rule' (Int
dot' forall a. Num a => a -> a -> a
+ Int
1), NameSet
ts')])
>			| (Lr1 Int
rule' Int
dot' NameSet
ts) <- [Lr1Item]
j ]


>		propagated :: [(Lr0Item, Int, Lr0Item)]
>		propagated :: [(Lr0Item, Int, Lr0Item)]
propagated = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
>		 (case Grammar -> Int -> Int -> Maybe Int
findRule Grammar
gram Int
rule' Int
dot' of
>		     Maybe Int
Nothing -> []
>		     Just Int
x  -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
x [(Int, Int)]
goto of
>				  Maybe Int
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"propagated"
>				  Just Int
k  -> [(Lr0Item
item, Int
k, Int -> Int -> Lr0Item
Lr0 Int
rule' (Int
dot' forall a. Num a => a -> a -> a
+ Int
1))])
>			| (Lr1 Int
rule' Int
dot' NameSet
ts) <- [Lr1Item]
j, Int
dummyTok forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (NameSet -> [Int]
NameSet.toAscList NameSet
ts) ]












> startLookahead :: Grammar -> Bool -> Name
> startLookahead :: Grammar -> Bool -> Int
startLookahead Grammar
gram Bool
partial = if Bool
partial then Int
errorTok else Grammar -> Int
eof_term Grammar
gram












> 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 a. (forall s. ST s a) -> a
runST (do
>	    STArray s Int [(Lr0Item, NameSet)]
arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
n_states) []
>	    forall s.
STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
propagate STArray s Int [(Lr0Item, NameSet)]
arr (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Lr0Item, NameSet)
-> [(Int, Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)]
fold_lookahead [] [(Int, Lr0Item, NameSet)]
spont)
>	    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)]
_   []  = 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 forall i e. Ix i => Array i e -> i -> e
! Int
j,
>				            Lr0Item
item forall a. Eq a => a -> a -> Bool
== Lr0Item
item' ]
>		[(Int, Lr0Item, NameSet)]
new_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)]
arr [(Int, Lr0Item, NameSet)]
items []
>		forall s.
STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
add_lookaheads STArray s Int [(Lr0Item, NameSet)]
arr [(Int, Lr0Item, NameSet)]
new
>		forall s.
STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
propagate STArray s Int [(Lr0Item, NameSet)]
arr [(Int, Lr0Item, NameSet)]
new_new










> 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)]
_      [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
> add_lookaheads STArray s Int [(Lr0Item, NameSet)]
arr ((Int
i,Lr0Item
item,NameSet
s) : [(Int, Lr0Item, NameSet)]
lookaheads) = do
>	[(Lr0Item, NameSet)]
las <- 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
>	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)
>	forall s.
STArray s Int [(Lr0Item, NameSet)]
-> [(Int, Lr0Item, NameSet)] -> ST s ()
add_lookaheads STArray s Int [(Lr0Item, NameSet)]
arr [(Int, Lr0Item, NameSet)]
lookaheads


> 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 = 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 <- 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
>	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 forall a. Eq a => a -> a -> Bool
== Lr0Item
item' = (Lr0Item
item, NameSet
s NameSet -> NameSet -> NameSet
`NameSet.union` NameSet
s') forall a. a -> [a] -> [a]
: [(Lr0Item, NameSet)]
las
>	| Bool
otherwise     = (Lr0Item, NameSet)
m 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 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 forall a. Eq a => a -> a -> Bool
== Lr0Item
item' =
>		let s'' :: NameSet
s'' = (Int -> Bool) -> NameSet -> NameSet
NameSet.filter (\Int
x -> Bool -> Bool
not (Int -> NameSet -> Bool
NameSet.member Int
x NameSet
s')) NameSet
s in
>		if NameSet -> Bool
NameSet.null NameSet
s'' then [(Int, Lr0Item, NameSet)]
new else
>		((Int
i,Lr0Item
item,NameSet
s'')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)]
>		-> [(Int,Lr0Item,NameSet)]
> fold_lookahead :: (Int, Lr0Item, NameSet)
-> [(Int, Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)]
fold_lookahead (Int, Lr0Item, NameSet)
l [] = [(Int, Lr0Item, NameSet)
l]
> fold_lookahead l :: (Int, Lr0Item, NameSet)
l@(Int
i,Lr0Item
item,NameSet
s) (m :: (Int, Lr0Item, NameSet)
m@(Int
i',Lr0Item
item',NameSet
s'):[(Int, Lr0Item, NameSet)]
las)
>  	| Int
i forall a. Eq a => a -> a -> Bool
== Int
i' Bool -> Bool -> Bool
&& Lr0Item
item forall a. Eq a => a -> a -> Bool
== Lr0Item
item' = (Int
i,Lr0Item
item, NameSet
s NameSet -> NameSet -> NameSet
`NameSet.union` NameSet
s')forall a. a -> [a] -> [a]
:[(Int, Lr0Item, NameSet)]
las
>	| Int
i forall a. Ord a => a -> a -> Bool
< Int
i' = (Int
i,Lr0Item
item,NameSet
s)forall a. a -> [a] -> [a]
:(Int, Lr0Item, NameSet)
mforall a. a -> [a] -> [a]
:[(Int, Lr0Item, NameSet)]
las
>	| Bool
otherwise = (Int, Lr0Item, NameSet)
m forall a. a -> [a] -> [a]
: (Int, Lr0Item, NameSet)
-> [(Int, Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)]
fold_lookahead (Int, Lr0Item, NameSet)
l [(Int, Lr0Item, NameSet)]
las










      -> [(Int, Lr0Item, Set Name)]		-- spontaneous lookaheads
      -> Array Int [(Lr0Item, Int, Lr0Item)]	-- propagated lookaheads
      -> Array Int [(Lr0Item, Set Name)]




      = rebuildArray $ fst (mkClosure (\(_,new) _ -> null new) propagate






        rebuildArray :: [(Int, Lr0Item, Set Name)] -> Array Int [(Lr0Item, Set Name)]
















      	   new_new = foldr (\i new -> getNew i las new) [] items








addLookahead :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)]
      	-> [(Int,Lr0Item,Set Name)]












getNew :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)]
      -> [(Int,Lr0Item,Set Name)] -> [(Int,Lr0Item,Set Name)]




























> mergeLookaheadInfo
>	:: Array Int [(Lr0Item, NameSet)] 	-- lookahead info
>	-> [(Set Lr0Item, [(Name,Int)])] 	-- state table
>	-> [ ([Lr1Item], [(Name,Int)]) ]


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


>	  mergeIntoSet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([Lr1Item], [(Name, Int)])
>	  mergeIntoSet :: ItemSetWithGotos -> Int -> ([Lr1Item], [(Int, Int)])
mergeIntoSet (Set Lr0Item
items, [(Int, Int)]
goto) Int
i
>		= (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map Lr0Item -> [Lr1Item]
mergeIntoItem (forall a. Set a -> [a]
Set.toAscList Set Lr0Item
items)), [(Int, 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 forall i e. Ix i => Array i e -> i -> e
! Int
i,
>					    Lr0Item
item forall a. Eq a => a -> a -> Bool
== Lr0Item
item' ] of
>					[] -> NameSet
NameSet.empty
>					[NameSet
x] -> NameSet
x
>					[NameSet]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"mergIntoItem"


















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








> genActionTable :: Grammar -> ([Name] -> NameSet) ->
>		 [([Lr1Item],[(Name,Int)])] -> ActionTable
> genActionTable :: Grammar
-> ([Int] -> NameSet) -> [([Lr1Item], [(Int, Int)])] -> ActionTable
genActionTable Grammar
g [Int] -> NameSet
first [([Lr1Item], [(Int, Int)])]
sets = ActionTable
actionTable
>   where
>	Grammar { first_term :: Grammar -> Int
first_term = Int
fst_term,
>		  terminals :: Grammar -> [Int]
terminals = [Int]
terms,
>		  starts :: Grammar -> [([Char], Int, Int, Bool)]
starts = [([Char], Int, Int, Bool)]
starts',
>       	  priorities :: Grammar -> [(Int, Priority)]
priorities = [(Int, Priority)]
prios } = Grammar
g


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


>       term_lim :: (Int, Int)
term_lim = (forall a. [a] -> a
head [Int]
terms,forall a. [a] -> a
last [Int]
terms)
>       actionTable :: ActionTable
actionTable = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Lr1Item], [(Int, Int)])]
setsforall a. Num a => a -> a -> a
-Int
1)
>             [ (Int
set_no, 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 (Int, Int)
term_lim 
>				([(Int, Int)] -> [Lr1Item] -> [(Int, LRAction)]
possActions [(Int, Int)]
goto [Lr1Item]
set))
>                   | (([Lr1Item]
set,[(Int, Int)]
goto),Int
set_no) <- forall a b. [a] -> [b] -> [(a, b)]
zip [([Lr1Item], [(Int, Int)])]
sets [Int
0..] ]


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


>	possActions :: [(Int, Int)] -> [Lr1Item] -> [(Int, LRAction)]
possActions [(Int, Int)]
goto [Lr1Item]
coll = 
>		(forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ forall {p}. [(Int, Int)] -> p -> Lr1Item -> [(Int, LRAction)]
possAction [(Int, Int)]
goto [Lr1Item]
coll Lr1Item
item |
>				Lr1Item
item <- Grammar -> ([Int] -> NameSet) -> [Lr1Item] -> [Lr1Item]
closure1 Grammar
g [Int] -> NameSet
first [Lr1Item]
coll ])




























































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


>	res (LR'Multiple [LRAction]
as LRAction
x) (LR'Multiple [LRAction]
bs LRAction
x')
>	       = case LRAction -> LRAction -> LRAction
res LRAction
x LRAction
x' of 
>		   LR'Multiple [LRAction]
cs LRAction
a
>		     | LRAction
a forall a. Eq a => a -> a -> Bool
== LRAction
x    -> [LRAction] -> LRAction -> LRAction
LR'Multiple (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ LRAction
x' forall a. a -> [a] -> [a]
: [LRAction]
as forall a. [a] -> [a] -> [a]
++ [LRAction]
bs forall a. [a] -> [a] -> [a]
++ [LRAction]
cs) LRAction
x
>		     | LRAction
a forall a. Eq a => a -> a -> Bool
== LRAction
x'   -> [LRAction] -> LRAction -> LRAction
LR'Multiple (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ LRAction
x  forall a. a -> [a] -> [a]
: [LRAction]
as forall a. [a] -> [a] -> [a]
++ [LRAction]
bs forall a. [a] -> [a] -> [a]
++ [LRAction]
cs) LRAction
x'
>		     | Bool
otherwise -> forall a. HasCallStack => [Char] -> a
error [Char]
"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
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 forall a. Ord a => a -> a -> Bool
< Int
j     -> LRAction
b
>               		| Int
i 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
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 forall a. Ord a => a -> a -> Bool
< Int
j     -> LRAction
b
>               		| Int
j forall a. Ord a => a -> a -> Bool
> Int
i     -> LRAction
a
>				| Int
r 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"confict in resolve"








> countConflicts :: ActionTable -> (Array Int (Int,Int), (Int,Int))
> countConflicts :: ActionTable -> (Array Int (Int, Int), (Int, Int))
countConflicts ActionTable
action
>   = (Array Int (Int, Int)
conflictArray, forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
a,Int
b) (Int
c,Int
d) -> (Int
aforall a. Num a => a -> a -> a
+Int
c, Int
bforall a. Num a => a -> a -> a
+Int
d)) (Int
0,Int
0) [(Int, Int)]
conflictList)
>   
>   where
>	   
>	conflictArray :: Array Int (Int, Int)
conflictArray = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (forall i e. Array i e -> (i, i)
Array.bounds ActionTable
action) [(Int, Int)]
conflictList
>	conflictList :: [(Int, Int)]
conflictList  = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {a} {i}.
(Num a, Num b) =>
(a, Array i LRAction) -> (a, b)
countConflictsState (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)
>	  = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {b}. (Num a, Num b) => LRAction -> (a, b) -> (a, b)
countMultiples (a
0,b
0) (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 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 forall a. Num a => a -> a -> a
+ b
1)
>	    countMultiples (LR'Multiple [LRAction]
_ LRAction
_) (a, b)
_
>	    	= forall a. HasCallStack => [Char] -> a
error [Char]
"bad conflict representation"
>	    countMultiples LRAction
_ (a, b)
c = (a, b)
c






> findRule :: Grammar -> Int -> Int -> Maybe Name
> findRule :: Grammar -> Int -> Int -> Maybe Int
findRule Grammar
g Int
rule Int
dot = 
>	case Grammar -> Int -> Production
lookupProdNo Grammar
g Int
rule of
>	   (Int
_,[Int]
lhs,([Char], [Int])
_,Priority
_) -> case forall a. Int -> [a] -> [a]
drop Int
dot [Int]
lhs of
>		            (Int
a:[Int]
_) -> forall a. a -> Maybe a
Just Int
a
>      			    [Int]
_     -> forall a. Maybe a
Nothing