From 41c176e67e0f6790c7809b8e646eb5f9031395b2 Mon Sep 17 00:00:00 2001 From: Karim Date: Sat, 8 Jun 2024 10:03:19 +0300 Subject: [PATCH] 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 | 22 ++++++++++++++- lib/tabular/src/Happy/Tabular/LALR.lhs | 36 ++++++++++++++----------- 2 files changed, 41 insertions(+), 17 deletions(-) diff --git a/lib/tabular/src/Happy/Tabular/First.lhs b/lib/tabular/src/Happy/Tabular/First.lhs index d6650966..f499d087 100644 --- a/lib/tabular/src/Happy/Tabular/First.lhs +++ b/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 diff --git a/lib/tabular/src/Happy/Tabular/LALR.lhs b/lib/tabular/src/Happy/Tabular/LALR.lhs index 2b60046e..197f736f 100644 --- a/lib/tabular/src/Happy/Tabular/LALR.lhs +++ b/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