Make Name a newtype

Co-authored-by: Sebastian Graf <[email protected]>

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 ]
 
 

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

lib/frontend/src/Happy/Frontend/AttrGrammar.lhs

@@ -8,6 +8,9 @@
 > , AgConditional(..)
 
 > , HasLexer (..)
+
+> , Index
+
 > , agLexAll
 > , subRefVal
 > , selfRefVal
@@ -17,20 +20,22 @@
 > import Data.Char
 > import Happy.Frontend.ParseMonad.Class
 
+> type Index = Int
+
 > data AgToken
 >   = AgTok_LBrace
 >   | AgTok_RBrace
 >   | AgTok_Where
 >   | 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]

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
 

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