Impelement another mkFirst function

mkFirst' is based on `(\env -> map (fn env) env)` environment reading and
updating pattern.

lib/tabular/src/Happy/Tabular/First.lhs

@@ -9,7 +9,7 @@ Implementation of FIRST
 > import Happy.Tabular.NameSet ( NameSet )
 > import qualified Happy.Tabular.NameSet as Set
 > import Happy.Grammar
-> import Data.Maybe (fromMaybe)
+> import Data.Maybe (fromMaybe, fromJust)
 
 \subsection{Utilities}
 
@@ -59,3 +59,23 @@ This will never terminate.
 >                    | otherwise   = Set.unions [ joinSymSets currFstSet rhs
 >                                               | rl <- prodsOfName s
 >                                               , let Production _ rhs _ _ = prodNo rl ]
+
+
+> mkFirst' :: Grammar e -> [Name] -> NameSet
+> mkFirst' (Grammar { first_term = fst_term
+>                   , lookupProdNo = prodNo
+>                   , lookupProdsOfName = prodsOfName
+>                   , non_terminals = nts
+>                   })
+>       = joinSymSets (\h -> fromMaybe (Set.singleton h) (lookup h env))
+>   where
+>       terminalP s = s >= fst_term
+>       env = mkClosure (==) (\f -> map (first f) f) [(name,Set.empty) | name <- nts]
+>       first :: [(Name, NameSet)] -> (Name, NameSet) -> (Name, NameSet)
+>       first currFstSets (symbol, _) =
+>                        (symbol , Set.unions [ joinSymSets currFstSet rhs
+>                                   | rl <- prodsOfName symbol
+>                                   , let Production _ rhs _ _ = prodNo rl ])
+>            where
+>              currFstSet s | terminalP s = Set.singleton s
+>                           | otherwise   = fromJust $ lookup s currFstSets

lib/tabular/src/Happy/Tabular/LALR.lhs

@@ -6,7 +6,7 @@ Generation of LALR parsing tables.
 -----------------------------------------------------------------------------
 
 > {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
->
+
 > module Happy.Tabular.LALR
 >       (genActionTable, genGotoTable, genLR0items, precalcClosure0,
 >        propLookaheads, calcLookaheads, mergeLookaheadInfo, countConflicts,
@@ -100,19 +100,25 @@ 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 g =
+> precalcClosure0 g@(Grammar { first_term = fst_term
+>                            , lookupProdsOfName = prodsOfName
+>                            , non_terminals = nts
+>                            }) =
 >       \n -> maybe [] id (lookup n info')
 >  where
->
+
 >       info' :: [(Name, RuleList)]
->       info' = map (\(n,rules) -> (n,map (\rule -> Lr0 rule 0) (IntSet.toAscList rules))) info
+>       info' = [ (n, lr0items)
+>               | (n, rules) <- info
+>               , let lr0items = [Lr0 rule 0 | rule <- IntSet.toAscList rules] ]
 
 >       info :: [(Name, IntSet)]
 >       info = mkClosure (==) (\f -> map (follow f) f)
->                       (map (\nt -> (nt,IntSet.fromList (lookupProdsOfName g nt))) nts)
+>                       [ (nt, IntSet.fromList $ prodsOfName nt)
+>                       | nt <- nts ]
 
 >       follow :: [(Name, IntSet)] -> (Name, IntSet) -> (Name, IntSet)
->       follow f (nt,rules) = (nt, unionIntMap (followNT f) rules `IntSet.union` rules)
+>       follow f (nt, rules) = (nt, unionIntMap (followNT f) rules `IntSet.union` rules)
 
 >       followNT :: [(Name, IntSet)] -> Int -> IntSet
 >       followNT f rule =
@@ -121,15 +127,13 @@ using a memo table so that no work is repeated.
 >                               maybe (error "followNT") id (lookup nt f)
 >                       _ -> IntSet.empty
 
->       nts = non_terminals g
->       fst_term = first_term g
 
 > closure0 :: Grammar e -> (Name -> RuleList) -> Set Lr0Item -> Set Lr0Item
 > closure0 g closureOfNT set = Set.foldr addRules Set.empty set
 >    where
 >       fst_term = first_term g
 >       addRules rule set' = Set.union (Set.fromList (rule : closureOfRule rule)) set'
->
+
 >       closureOfRule (Lr0 rule dot) =
 >           case findRule g rule dot of
 >               (Just nt) | nt >= firstStartTok && nt < fst_term
@@ -245,10 +249,10 @@ information about which sets were generated by which others.
 
 >    addItems :: ([ItemSetWithGotos], [Set Lr0Item])
 >             -> ([ItemSetWithGotos], [Set Lr0Item])
->
+
 >    addItems (oldSets,newSets) = (newOldSets, reverse newNewSets)
 >     where
->
+
 >       newOldSets = oldSets ++ (zip newSets intgotos)
 
 >       itemSets = map fst oldSets ++ newSets
@@ -281,7 +285,7 @@ Unfortunately, the code's a little opaque.
 >                   [[(Name,Int)]],
 >                   [Set Lr0Item])
 >               -> (Int, [[(Name,Int)]], [Set Lr0Item])
->
+
 >       numberSets [] (i,gotos',newSets') = (i,([]:gotos'),newSets')
 >       numberSets ((x,gotoix):rest) (i,g':gotos',newSets')
 >          = numberSets rest
@@ -491,7 +495,7 @@ Generating the goto table doesn't need lookahead info.
 >       Grammar{ first_nonterm = fst_nonterm,
 >                first_term    = fst_term,
 >                non_terminals = non_terms } = g
->
+
 >       -- goto array doesn't include %start symbols
 >       gotoTable  = listArray (0,length sets-1)
 >         [
@@ -634,12 +638,12 @@ Count the conflicts
 > countConflicts :: ActionTable -> (Array Int (Int,Int), (Int,Int))
 > countConflicts action
 >   = (conflictArray, foldl' (\(a,b) (c,d) -> let ac = a + c; bd = b + d in ac `seq` bd `seq` (ac,bd)) (0,0) conflictList)
->
+
 >   where
->
+
 >       conflictArray = listArray (Array.bounds action) conflictList
 >       conflictList  = map countConflictsState (assocs action)
->
+
 >       countConflictsState (_state, actions)
 >         = foldr countMultiples (0,0) (elems actions)
 >         where