From e5eadf174fe8cd5915eaf048da6bd776b445185d Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 21 Jan 2022 03:44:09 -0500 Subject: [PATCH] Make Name a newtype Co-authored-by: Sebastian Graf --- .../src/Happy/Backend/GLR/ProduceCode.lhs | 14 +-- .../src/Happy/Backend/LALR/ProduceCode.lhs | 57 ++++++------ .../src/Happy/Frontend/AttrGrammar.lhs | 11 ++- .../Happy/Frontend/AttrGrammar/Mangler.lhs | 18 ++-- lib/frontend/src/Happy/Frontend/Mangler.lhs | 21 +++-- lib/grammar/src/Happy/Grammar.lhs | 23 +++-- lib/tabular/src/Happy/Tabular/First.lhs | 3 +- lib/tabular/src/Happy/Tabular/LALR.lhs | 27 +++--- lib/tabular/src/Happy/Tabular/NameSet.hs | 86 +++++++++++++++++-- 9 files changed, 179 insertions(+), 81 deletions(-) diff --git a/lib/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs b/lib/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs index a4738f0d..c9794f8f 100644 --- a/lib/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs +++ b/lib/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs @@ -278,7 +278,7 @@ that will be used for them in the GLR parser. > TokenFixed t -> t > TokenWithValue e -> substExpressionWithHole e "_" -> toGSym :: [(Int, String)] -> Int -> String +> toGSym :: [(Name, String)] -> Name -> String > toGSym gsMap i > = case lookup i gsMap of > Nothing -> error $ "No representation for symbol " ++ show i @@ -291,7 +291,7 @@ function that can be included as the action table in the GLR parser. It also shares identical reduction values as CAFs > writeActionTbl -> :: ActionTable -> [(Int,String)] -> (Name->String) +> :: ActionTable -> [(Name,String)] -> (Name->String) > -> GhcExts -> Grammar String -> ShowS > writeActionTbl acTbl gsMap semfn_map exts g > = interleave "\n" @@ -331,7 +331,7 @@ It also shares identical reduction values as CAFs > mkRed r = "red_" ++ show r > mkReductions = [ mkRedDefn p -> | p@(_, Production n _ _ _) <- zip [0..] $ productions g +> | p@(_, Production n _ _ _) <- zip [MkName 0 ..] $ productions g > , n `notElem` start_productions g ] > mkRedDefn (r, Production lhs_id rhs_ids (_code,_dollar_vars) _) @@ -345,7 +345,7 @@ It also shares identical reduction values as CAFs %----------------------------------------------------------------------------- Do the same with the Happy goto table. -> writeGotoTbl :: GotoTable -> [(Int,String)] -> GhcExts -> ShowS +> writeGotoTbl :: GotoTable -> [(Name,String)] -> GhcExts -> ShowS > writeGotoTbl goTbl gsMap exts > = interleave "\n" (map str $ filter (not.null) mkLines) > . str errorLine . nl @@ -588,9 +588,11 @@ maps production name to the underlying (possibly shared) semantic function > mk_semfn_map :: SemInfo -> Array Name String > mk_semfn_map sem_info -> = array (0,maximum $ map fst prod_map) prod_map +> = array (i_min, i_max) prod_map > where -> prod_map = [ (p, mkSemFn_Name ij) +> i_min = MkName 0 +> i_max = MkName $ maximum $ map (getName . fst) prod_map +> prod_map = [ (MkName p, mkSemFn_Name ij) > | (_,_,_,pi') <- sem_info, (ij,_,ps) <- pi', p <- ps ] diff --git a/lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index ed7095e3..f002a1de 100644 --- a/lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -224,7 +224,7 @@ example where this matters. > | (n, ty) <- assocs nt_types, > (nt_types_index ! n) == n] -> where all_tyvars = [ 't':show n | (n, Nothing) <- assocs nt_types ] +> where all_tyvars = [ 't' : show (getName n) | (n, Nothing) <- assocs nt_types ] > str_tyvars = str (unwords all_tyvars) %----------------------------------------------------------------------------- @@ -305,7 +305,7 @@ happyMonadReduce to get polymorphic recursion. Sigh. > -- adjust the nonterminal number for the array-based parser > -- so that nonterminals start at zero. -> adjusted_nt = nt - first_nonterm' +> adjusted_nt = getName nt - getName first_nonterm' > mkReductionHdr lt' s = > let tysig = case lexer' of @@ -422,7 +422,7 @@ the left hand side of '@'. > TokenFixed t -> t > TokenWithValue e -> substExpressionWithHole e "happy_dollar_dollar" -> mkHappyTerminalVar :: Int -> Int -> String -> String +> mkHappyTerminalVar :: Int -> Name -> String -> String > mkHappyTerminalVar i t = > case lookup t token_rep of > Nothing -> pat @@ -431,7 +431,7 @@ the left hand side of '@'. > where > pat = mkHappyVar i -> tokIndex i = i - n_nonterminals - n_starts - 2 +> tokIndex i = getName i - n_nonterminals - n_starts - 2 > -- tokens adjusted to start at zero, see ARRAY_NOTES %----------------------------------------------------------------------------- @@ -505,7 +505,7 @@ machinery to discard states in the parser... > . str " f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n" > . str "\n" > where (first_token, last_token) = bounds token_names' -> nr_tokens = last_token - first_token + 1 +> nr_tokens = getName last_token - getName first_token + 1 action array indexed by (terminal * last_state) + state @@ -593,7 +593,7 @@ Note, this *could* introduce lack of polymophism, for types that have alphas in them. Maybe we should outlaw them inside { } -> nt_types_index :: Array Int Int +> nt_types_index :: Array Name Name > nt_types_index = array (bounds nt_types) > [ (a, fn a b) | (a, b) <- assocs nt_types ] > where @@ -734,7 +734,7 @@ directive determines the API of the provided function. > Nothing -> id > Just ag -> produceAttrEntries ag starts' -> produceEntry :: ((String, t0, Int, t1), Int) -> String -> String +> produceEntry :: ((String, t0, Name, t1), Int) -> String -> String > produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no) > = (if isNothing mAg then str name else str "do_" . str name) > . maybe_tks @@ -749,7 +749,7 @@ directive determines the API of the provided function. > then str "\\x -> happyReturn (let {" . mkHappyWrapCon (nt_types ! accept_nonterm) accept_nonterm (str "x'") > . str " = " . mkHappyOut accept_nonterm . str " x} in x')" > else str "\\x -> case x of {HappyAbsSyn" -> . shows (nt_types_index ! accept_nonterm) +> . showsName (nt_types_index ! accept_nonterm) > . str " z -> happyReturn z; _other -> notHappyAtAll }" > ) > where @@ -903,7 +903,7 @@ See notes under "Action Tables" above for some subtleties in this function. > mkTables -> :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int -> (Int, Int) -> +> :: ActionTable -> GotoTable -> Name -> Name -> Int -> Int -> Int -> (Name, Name) -> > ( [Int] -- happyActOffsets > , [Int] -- happyGotoOffsets > , [Int] -- happyTable @@ -958,14 +958,16 @@ See notes under "Action Tables" above for some subtleties in this function. > explist_actions = [ (state, concatMap f $ assocs acts) > | (state, acts) <- assocs action ] > where -> f (t, LR'Shift _ _ ) = [t - fst token_names_bound] +> f (t, LR'Shift _ _ ) = [getName t - getName (fst token_names_bound)] > f (_, _) = [] > > -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0). > -- (see ARRAY_NOTES) +> adjust :: Name -> Int > adjust token | token == errorTok = 0 -> | otherwise = token - fst_term + 1 +> | otherwise = getName token - getName fst_term + 1 > +> mkActVals :: [(Name, LRAction)] -> LRAction -> [(Int, Int)] > mkActVals assocs' default_act = > [ (adjust token, actionVal act) > | (token, act) <- assocs' @@ -986,7 +988,7 @@ See notes under "Action Tables" above for some subtleties in this function. > -- adjust nonterminals by -first_nonterm', so they start at zero > -- (see ARRAY_NOTES) > mkGotoVals assocs' = -> [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ] +> [ (getName token - getName first_nonterm', i) | (token, Goto i) <- assocs' ] > > sorted_actions = sortBy (flip cmp_state) (actions ++ gotos) > cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_) @@ -1006,7 +1008,7 @@ See notes under "Action Tables" above for some subtleties in this function. > genTables > :: Int -- number of actions > -> Int -- maximum token no. -> -> (Int, Int) -- token names bounds +> -> (Name, Name) -- token names bounds > -> [TableEntry] -- entries for the table > -> [(Int, [Int])] -- expected tokens lists > -> ST s ( UArray Int Int -- table @@ -1041,7 +1043,7 @@ See notes under "Action Tables" above for some subtleties in this function. > n_states = n_actions - 1 > mAX_TABLE_SIZE = n_states * (max_token + 1) > (first_token, last') = token_names_bound -> n_token_names = last' - first_token + 1 +> n_token_names = getName last' - getName first_token + 1 > genTables' @@ -1156,7 +1158,7 @@ slot is free or not. > writeArray check (off+t) t > addState off table check state -> notFail :: (Int, LRAction) -> Bool +> notFail :: (Name, LRAction) -> Bool > notFail (_, LR'Fail) = False > notFail _ = True @@ -1169,33 +1171,36 @@ slot is free or not. ----------------------------------------------------------------------------- -- Misc. +> showsName :: Name -> ShowS +> showsName = shows . getName + > comment :: String > comment = > "-- parser produced by Happy Version " ++ showVersion version ++ "\n\n" -> mkAbsSynCon :: Array Int Int -> Int -> String -> String -> mkAbsSynCon fx t = str "HappyAbsSyn" . shows (fx ! t) +> mkAbsSynCon :: Array Name Name -> Name -> String -> String +> mkAbsSynCon fx t = str "HappyAbsSyn" . showsName (fx ! t) > mkHappyVar, mkReduceFun, mkDummyVar :: Int -> String -> String > mkHappyVar n = str "happy_var_" . shows n > mkReduceFun n = str "happyReduce_" . shows n > mkDummyVar n = str "happy_x_" . shows n -> mkHappyWrap :: Int -> String -> String -> mkHappyWrap n = str "HappyWrap" . shows n +> mkHappyWrap :: Name -> String -> String +> mkHappyWrap n = str "HappyWrap" . showsName n -> mkHappyWrapCon :: Maybe a -> Int -> (String -> String) -> String -> String +> mkHappyWrapCon :: Maybe a -> Name -> (String -> String) -> String -> String > mkHappyWrapCon Nothing _ s = s > mkHappyWrapCon (Just _) n s = brack' (mkHappyWrap n . strspace . s) -> mkHappyIn, mkHappyOut :: Int -> String -> String -> mkHappyIn n = str "happyIn" . shows n -> mkHappyOut n = str "happyOut" . shows n +> mkHappyIn, mkHappyOut :: Name -> String -> String +> mkHappyIn n = str "happyIn" . showsName n +> mkHappyOut n = str "happyOut" . showsName n -> typeParam, typeParamOut :: Int -> Maybe String -> ShowS -> typeParam n Nothing = char 't' . shows n +> typeParam, typeParamOut :: Name -> Maybe String -> ShowS +> typeParam n Nothing = char 't' . showsName n > typeParam _ (Just ty) = brack ty -> typeParamOut n Nothing = char 't' . shows n +> typeParamOut n Nothing = char 't' . showsName n > typeParamOut n (Just _) = mkHappyWrap n > specReduceFun :: Int -> Bool diff --git a/lib/frontend/src/Happy/Frontend/AttrGrammar.lhs b/lib/frontend/src/Happy/Frontend/AttrGrammar.lhs index 5bd203a0..9a03613f 100644 --- a/lib/frontend/src/Happy/Frontend/AttrGrammar.lhs +++ b/lib/frontend/src/Happy/Frontend/AttrGrammar.lhs @@ -8,6 +8,9 @@ > , AgConditional(..) > , HasLexer (..) + +> , Index + > , agLexAll > , subRefVal > , selfRefVal @@ -17,6 +20,8 @@ > import Data.Char > import Happy.Frontend.ParseMonad.Class +> type Index = Int + > data AgToken > = AgTok_LBrace > | AgTok_RBrace @@ -24,13 +29,13 @@ > | AgTok_Semicolon > | AgTok_Eq > | AgTok_SelfRef String -> | AgTok_SubRef (Int, String) +> | AgTok_SubRef (Index, String) > | AgTok_RightmostRef String > | AgTok_Unknown String > | AgTok_EOF > deriving (Show,Eq,Ord) -> subRefVal :: AgToken -> (Int, String) +> subRefVal :: AgToken -> (Index, String) > subRefVal (AgTok_SubRef x) = x > subRefVal _ = error "subRefVal: Bad value" > selfRefVal :: AgToken -> String @@ -55,7 +60,7 @@ a separate data type for each core rule type. We don't need one for > data AgSelfAssign = MkAgSelfAssign String [AgToken] > deriving (Show,Eq,Ord) -> data AgSubAssign = MkAgSubAssign (Int, String) [AgToken] +> data AgSubAssign = MkAgSubAssign (Index, String) [AgToken] > deriving (Show,Eq,Ord) > data AgConditional = MkAgConditional [AgToken] diff --git a/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs b/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs index 50a11e8f..ff01d08b 100644 --- a/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs +++ b/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs @@ -21,7 +21,7 @@ manipulation and let binding goop > import Control.Monad -> rewriteAttributeGrammar :: [Name] -> [Name] -> String -> AttributeGrammarExtras -> M (String,[Int]) +> rewriteAttributeGrammar :: [Name] -> [Name] -> String -> AttributeGrammarExtras -> M (String,[Index]) > rewriteAttributeGrammar lhs nonterm_names code ag = first we need to parse the body of the code block @@ -43,7 +43,8 @@ manipulation and let binding goop now check that $i references are in range -> in do let prods = mentionedProductions rules +> in do let prods :: [Index] +> prods = mentionedProductions rules > mapM_ checkArity prods and output the rules @@ -57,7 +58,8 @@ manipulation and let binding goop > return (rulesStr,nub (allSubProductions++prods)) -> where arity = length lhs +> where arity :: Index +> arity = length lhs > partitionRules a b c [] = (a,b,c) > partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules a (x:b) c xs @@ -70,10 +72,10 @@ manipulation and let binding goop > mentionedProductions rules = [ i | (AgTok_SubRef (i,_)) <- concat (map getTokens rules) ] -> getTokens (SelfAssign (MkAgSelfAssign _ toks)) = toks -> getTokens (SubAssign (MkAgSubAssign _ toks)) = toks -> getTokens (Conditional (MkAgConditional toks)) = toks -> getTokens (RightmostAssign _ toks) = toks +> getTokens (SelfAssign (MkAgSelfAssign _ toks)) = toks +> getTokens (SubAssign (MkAgSubAssign _ toks)) = toks +> getTokens (Conditional (MkAgConditional toks)) = toks +> getTokens (RightmostAssign _ toks) = toks > > checkArity x = when (x > arity) $ addErr (show x++" out of range") @@ -82,7 +84,7 @@ manipulation and let binding goop -- Actually emit the code for the record bindings and conditionals -- -> formatRules :: Int -> [String] -> String -> [Name] +> formatRules :: Index -> [String] -> String -> [Index] > -> [AgSelfAssign] -> [AgSubAssign] -> [AgConditional] > -> M String diff --git a/lib/frontend/src/Happy/Frontend/Mangler.lhs b/lib/frontend/src/Happy/Frontend/Mangler.lhs index 17283246..622785e6 100644 --- a/lib/frontend/src/Happy/Frontend/Mangler.lhs +++ b/lib/frontend/src/Happy/Frontend/Mangler.lhs @@ -70,14 +70,13 @@ go do special processing. If not, pass on to the regular processing routine > terminal_strs = concat (map getTerm dirs) ++ [eofName] -> n_starts = length starts' -> n_nts = length nonterm_strs -> n_ts = length terminal_strs -> first_nt = firstStartTok + n_starts -> first_t = first_nt + n_nts -> last_start = first_nt - 1 -> last_nt = first_t - 1 -> last_t = first_t + n_ts - 1 +> first_nt, first_t, last_start, last_nt, last_t :: Name + +> first_nt = MkName $ getName firstStartTok + length starts' +> first_t = MkName $ getName first_nt + length nonterm_strs +> last_start = MkName $ getName first_nt - 1 +> last_nt = MkName $ getName first_t - 1 +> last_t = MkName $ getName first_t + length terminal_strs - 1 > start_names = [ firstStartTok .. last_start ] > nonterm_names = [ first_nt .. last_nt ] @@ -210,11 +209,11 @@ Translate the rules from string to name-based. > > let -> type_array :: Array Int (Maybe String) +> type_array :: Array Name (Maybe String) > type_array = accumArray (\_ x -> x) Nothing (first_nt, last_nt) > [ (nm, Just t) | (nm, t) <- tys ] -> env_array :: Array Int String +> env_array :: Array Name String > env_array = array (errorTok, last_t) name_env > -- in @@ -228,7 +227,7 @@ Get the token specs in terms of Names. > let > ass = combinePairs [ (a,no) > | (Production a _ _ _,no) <- zip productions' [0..] ] -> arr = array (firstStartTok, length ass - 1 + firstStartTok) ass +> arr = array (firstStartTok, MkName $ length ass - 1 + getName firstStartTok) ass > lookup_prods :: Name -> [Int] > lookup_prods x | x >= firstStartTok && x < first_t = arr ! x diff --git a/lib/grammar/src/Happy/Grammar.lhs b/lib/grammar/src/Happy/Grammar.lhs index 64b86d37..960b7c1a 100644 --- a/lib/grammar/src/Happy/Grammar.lhs +++ b/lib/grammar/src/Happy/Grammar.lhs @@ -4,9 +4,11 @@ The Grammar data type. (c) 1993-2001 Andy Gill, Simon Marlow ----------------------------------------------------------------------------- +> {-# LANGUAGE GeneralizedNewtypeDeriving #-} + > -- | This module exports the 'Grammar' data type, which > module Happy.Grammar ( -> Name, +> Name (..), > > Production(..), > TokenSpec(..), @@ -23,8 +25,6 @@ The Grammar data type. > import Data.Array > import Happy.Grammar.ExpressionWithHole (ExpressionWithHole) -> type Name = Int - > data Production eliminator > = Production Name [Name] (eliminator,[Int]) Priority > deriving Show @@ -48,8 +48,8 @@ The Grammar data type. > terminals :: [Name], > non_terminals :: [Name], > starts :: [(String,Name,Name,Bool)], -> types :: Array Int (Maybe String), -> token_names :: Array Int String, +> types :: Array Name (Maybe String), +> token_names :: Array Name String, > first_nonterm :: Name, > first_term :: Name, > eof_term :: Name, @@ -117,6 +117,11 @@ The Grammar data type. ----------------------------------------------------------------------------- -- Magic name values +> newtype Name +> = MkName { getName :: Int } +> deriving ( Read, Show +> , Eq, Ord, Enum, Ix) + All the tokens in the grammar are mapped onto integers, for speed. The namespace is broken up as follows: @@ -152,7 +157,7 @@ For array-based parsers, see the note in Tabular/LALR.lhs. > dummyName = "%dummy" -- shouldn't occur in the grammar anywhere > firstStartTok, dummyTok, errorTok, epsilonTok :: Name -> firstStartTok = 3 -> dummyTok = 2 -> errorTok = 1 -> epsilonTok = 0 +> firstStartTok = MkName 3 +> dummyTok = MkName 2 +> errorTok = MkName 1 +> epsilonTok = MkName 0 diff --git a/lib/tabular/src/Happy/Tabular/First.lhs b/lib/tabular/src/Happy/Tabular/First.lhs index 1be62022..3a2fbce9 100644 --- a/lib/tabular/src/Happy/Tabular/First.lhs +++ b/lib/tabular/src/Happy/Tabular/First.lhs @@ -9,7 +9,6 @@ Implementation of FIRST > import Happy.Tabular.NameSet ( NameSet ) > import qualified Happy.Tabular.NameSet as Set > import Happy.Grammar -> import Data.IntSet (IntSet) \subsection{Utilities} @@ -45,7 +44,7 @@ This will never terminate. > [ (name,Set.empty) | name <- nts ] > getNext :: Name -> (a -> Production e) -> (Name -> [a]) -> -> [(Name, IntSet)] -> [(Name, NameSet)] +> -> [(Name, NameSet)] -> [(Name, NameSet)] > getNext fst_term prodNo prodsOfName env = > [ (nm, next nm) | (nm,_) <- env ] > where diff --git a/lib/tabular/src/Happy/Tabular/LALR.lhs b/lib/tabular/src/Happy/Tabular/LALR.lhs index aa8adf36..8e1a09a7 100644 --- a/lib/tabular/src/Happy/Tabular/LALR.lhs +++ b/lib/tabular/src/Happy/Tabular/LALR.lhs @@ -16,8 +16,10 @@ Generation of LALR parsing tables. > import Happy.Tabular.NameSet ( NameSet ) > import qualified Happy.Tabular.NameSet as NameSet > import Happy.Grammar -> import qualified Data.Set as Set hiding ( Set ) +> 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 @@ -30,6 +32,9 @@ Generation of LALR parsing tables. > unionMap :: (Ord b) => (a -> Set b) -> Set a -> Set b > unionMap f = Set.foldr (Set.union . f) Set.empty +> unionIntMap :: (Int -> IntSet) -> IntSet -> IntSet +> unionIntMap f = IntSet.foldr (IntSet.union . f) IntSet.empty + > unionNameMap :: (Name -> NameSet) -> NameSet -> NameSet > unionNameMap f = NameSet.foldr (NameSet.union . f) NameSet.empty @@ -55,8 +60,8 @@ This means rule $a$, with dot at $b$ (all starting at 0) > | LR'Multiple [LRAction] LRAction -- conflict > deriving (Eq,Show) -> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction) -> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto) +> type ActionTable = Array Int{-state-} (Array Name{-terminal#-} LRAction) +> type GotoTable = Array Int{-state-} (Array Name{-nonterminal #-} Goto) > data Goto = Goto Int | NoGoto > deriving (Eq, Show) @@ -98,21 +103,21 @@ using a memo table so that no work is repeated. > where > > info' :: [(Name, RuleList)] -> info' = map (\(n,rules) -> (n,map (\rule -> Lr0 rule 0) (NameSet.toAscList rules))) info +> info' = map (\(n,rules) -> (n,map (\rule -> Lr0 rule 0) (IntSet.toAscList rules))) info -> info :: [(Name, NameSet)] +> info :: [(Name, IntSet)] > info = mkClosure (==) (\f -> map (follow f) f) -> (map (\nt -> (nt,NameSet.fromList (lookupProdsOfName g nt))) nts) +> (map (\nt -> (nt,IntSet.fromList (lookupProdsOfName g nt))) nts) -> follow :: [(Name, NameSet)] -> (Name, NameSet) -> (Name, NameSet) -> follow f (nt,rules) = (nt, unionNameMap (followNT f) rules `NameSet.union` rules) +> follow :: [(Name, IntSet)] -> (Name, IntSet) -> (Name, IntSet) +> follow f (nt,rules) = (nt, unionIntMap (followNT f) rules `IntSet.union` rules) -> followNT :: [(Name, NameSet)] -> Int -> NameSet +> followNT :: [(Name, IntSet)] -> Int -> IntSet > followNT f rule = > case findRule g rule 0 of > Just nt | nt >= firstStartTok && nt < fst_term -> > maybe (error "followNT") id (lookup nt f) -> _ -> NameSet.empty +> _ -> IntSet.empty > nts = non_terminals g > fst_term = first_term g @@ -488,7 +493,7 @@ Generating the goto table doesn't need lookahead info. > -- goto array doesn't include %start symbols > gotoTable = listArray (0,length sets-1) > [ -> (array (fst_nonterm, fst_term-1) [ +> (array (fst_nonterm, MkName $ getName fst_term - 1) [ > (n, maybe NoGoto Goto (lookup n goto)) > | n <- non_terms, > n >= fst_nonterm, n < fst_term ]) diff --git a/lib/tabular/src/Happy/Tabular/NameSet.hs b/lib/tabular/src/Happy/Tabular/NameSet.hs index c95c86f9..ae55a1f4 100644 --- a/lib/tabular/src/Happy/Tabular/NameSet.hs +++ b/lib/tabular/src/Happy/Tabular/NameSet.hs @@ -1,8 +1,84 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Happy.Tabular.NameSet ( - NameSet, - module Data.IntSet -) where + -- * Set type + NameSet (..), + -- * Construction + empty, + singleton, + fromList, + -- * Deletion + delete, + -- * Query + member, + null, + -- * Combine + union, + unions, + difference, + (\\), + -- * Folds + foldr, + -- * Conversion + -- ** List + toAscList + ) where + +import Prelude hiding (foldr, null) + +import Data.Coerce +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Happy.Grammar + +newtype NameSet = MkNameSet IntSet + deriving (Read, Show, Eq, Ord) + +-- + +empty :: NameSet +empty = coerce IntSet.empty + +singleton :: Name -> NameSet +singleton = coerce IntSet.singleton + +fromList :: [Name] -> NameSet +fromList = coerce IntSet.fromList + +-- + +delete :: Name -> NameSet -> NameSet +delete = coerce IntSet.delete + +-- + +member :: Name -> NameSet -> Bool +member = coerce IntSet.member + +null :: NameSet -> Bool +null = coerce IntSet.null + +-- + +union :: NameSet -> NameSet -> NameSet +union = coerce IntSet.union + +unions :: [NameSet] -> NameSet +unions = coerce . IntSet.unions . fmap coerce + +difference :: NameSet -> NameSet -> NameSet +difference = coerce IntSet.difference + +(\\) :: NameSet -> NameSet -> NameSet +(\\) = coerce (IntSet.\\) + +-- + +foldr :: forall b. (Name -> b -> b) -> b -> NameSet -> b +foldr = coerce (IntSet.foldr :: (Int -> b -> b) -> b -> IntSet -> b) -import Data.IntSet +-- -type NameSet = IntSet +toAscList :: NameSet -> [Name] +toAscList = coerce IntSet.toAscList