Skip to content

Commit

Permalink
Make Name a newtype
Browse files Browse the repository at this point in the history 
Co-authored-by: Sebastian Graf <[email protected]>
  • Loading branch information
@Ericson2314 @sgraf812
Ericson2314 and sgraf812 committed Sep 26, 2024
1 parent 4b59fb3 commit e5eadf1
Show file tree
Hide file tree
Showing 9 changed files with 179 additions and 81 deletions.
14 changes: 8 additions & 6 deletions lib/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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"
Expand Down Expand Up @@ -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) _)
Expand All @@ -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
Expand Down Expand Up @@ -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 ]


Expand Down
57 changes: 31 additions & 26 deletions lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)

%-----------------------------------------------------------------------------
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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

%-----------------------------------------------------------------------------
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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'
Expand All @@ -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,_)
Expand All @@ -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
Expand Down Expand Up @@ -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'
Expand Down Expand Up @@ -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

Expand All @@ -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
Expand Down
11 changes: 8 additions & 3 deletions lib/frontend/src/Happy/Frontend/AttrGrammar.lhs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,9 @@
> , AgConditional(..)

> , HasLexer (..)

> , Index

> , agLexAll
> , subRefVal
> , selfRefVal
Expand All @@ -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
Expand All @@ -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]
Expand Down
18 changes: 10 additions & 8 deletions lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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")

Expand All @@ -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

Expand Down
21 changes: 10 additions & 11 deletions lib/frontend/src/Happy/Frontend/Mangler.lhs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 ]
Expand Down Expand Up @@ -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

Expand All @@ -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
Expand Down
Loading

0 comments on commit e5eadf1

Please sign in to comment.