Skip to content

Add OPTIONS_HAPPY pragma for passing flags to happy #342

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
sgraf812 merged 7 commits into from
Aug 16, 2025
+327 −200
Merged

Add OPTIONS_HAPPY pragma for passing flags to happy #342

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
0b247ad
Rename internal parser entry function from `happyParse` to `happyDoPa…
sgraf812 Aug 16, 2025
c4ac82d
Add pragma parsing to happy grammar
TOTBWF Aug 5, 2025
379edef
Use options from OPTIONS_HAPPY pragma
TOTBWF Aug 5, 2025
bbb7779
Add test for pragma parsing
TOTBWF Aug 5, 2025
25cb9e1
Address review comments
TOTBWF Aug 11, 2025
afc46f9
Boostrap with happy 2.1.6
TOTBWF Aug 11, 2025
b4df3e2
Fix the Pragma.y test
sgraf812 Aug 16, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
75 changes: 45 additions & 30 deletions app/Main.lhs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -28,6 +28,7 @@ Path settings auto-generated by Cabal:
> import System.Environment
> import System.Exit (exitWith, ExitCode(..))
> import Data.Char
> import Data.List ( union )
> import System.IO
> import Data.List( isSuffixOf )
> import Data.Version ( showVersion )
Expand Down Expand Up @@ -61,12 +62,7 @@ Read and parse the CLI arguments.
> usageInfo (usageHeader prog) argInfo)

> where
> runParserGen cli fl_name = do

If no -g flag has been passed, show a warning.

> unless (OptGhcTarget `elem` cli) $
> hPutStrLn stderr "Warning: With happy 2.0, the --ghc flag has become non-optional. To suppress this warning, pass the --ghc flag."
> runParserGen cliOpts fl_name = do

Open the file.

Expand All @@ -78,19 +74,38 @@ Open the file.

Parse, using bootstrapping parser.

> (BookendedAbsSyn hd abssyn tl) <- case parseYFileContents file of
> (BookendedAbsSyn pragma hd abssyn tl) <- case parseYFileContents file of
> Left err -> die (fl_name ++ ':' : err)
> Right bas -> return bas

Combine options set via OPTIONS_HAPPY with those provided via the CLI.

> opts <-
> case pragma of
> Just happyPragma -> do
> let (pragmaName, pragmaArgs) = break isSpace happyPragma
> when (pragmaName /= "OPTIONS_HAPPY") $
> die ("Unknown happy pragma '" ++ pragmaName ++ "', expected OPTIONS_HAPPY")
> case getOpt Permute argInfo (words pragmaArgs) of
> (pragmaOpts,_,[]) -> return (union pragmaOpts cliOpts)
> (_,_,errors) -> die ("Invalid options in OPTIONS_HAPPY: " ++ concat errors)
> Nothing -> return cliOpts

If no -g flag has been passed, show a warning.

> unless (OptGhcTarget `elem` opts) $
> hPutStrLn stderr "Warning: With happy 2.0, the --ghc flag has become non-optional. To suppress this warning, pass the --ghc flag."


Mangle the syntax into something useful.

> (g, mAg, common_options) <- case {-# SCC "Mangler" #-} mangler fl_name abssyn of
> Left s -> die (unlines s ++ "\n")
> Right gd -> return gd

> optPrint cli DumpMangle $ putStr $ show g
> optPrint opts DumpMangle $ putStr $ show g

> let select_reductions | OptGLR `elem` cli = select_all_reductions
> let select_reductions | OptGLR `elem` opts = select_all_reductions
> | otherwise = select_first_reduction

> let tables = genTables select_reductions g
Expand All @@ -103,11 +118,11 @@ Mangle the syntax into something useful.

Debug output

> optPrint cli DumpLR0 $ putStr $ show sets
> optPrint cli DumpAction $ putStr $ show action
> optPrint cli DumpGoto $ putStr $ show goto
> optPrint cli DumpLA $ putStr $ show lainfo
> optPrint cli DumpLA $ putStr $ show la
> optPrint opts DumpLR0 $ putStr $ show sets
> optPrint opts DumpAction $ putStr $ show action
> optPrint opts DumpGoto $ putStr $ show goto
> optPrint opts DumpLA $ putStr $ show lainfo
> optPrint opts DumpLA $ putStr $ show la

Report any unused rules and terminals

Expand All @@ -119,7 +134,7 @@ Report any unused rules and terminals

Print out the info file.

> info_filename <- getInfoFileName name cli
> info_filename <- getInfoFileName name opts
> let info = genInfoFile
> (map fst sets)
> g
Expand All @@ -139,7 +154,7 @@ Print out the info file.

Pretty print the AbsSyn.

> pretty_filename <- getPrettyFileName name cli
> pretty_filename <- getPrettyFileName name opts
> case pretty_filename of
> Just s -> do
> let out = render (ppAbsSyn abssyn)
Expand Down Expand Up @@ -175,10 +190,10 @@ Report any conflicts in the grammar.
Now, let's get on with generating the parser. Firstly, find out what kind
of code we should generate, and where it should go:

> outfilename <- getOutputFileName fl_name cli
> opt_coerce <- getCoerce cli
> opt_strict <- getStrict cli
> opt_debug <- getDebug cli
> outfilename <- getOutputFileName fl_name opts
> opt_coerce <- getCoerce opts
> opt_strict <- getStrict opts
> opt_debug <- getDebug opts

Add any special options or imports required by the parsing machinery.

Expand All @@ -187,7 +202,7 @@ Add any special options or imports required by the parsing machinery.
> (case hd of Just s -> s; Nothing -> "")
> ++ importsToInject opt_debug

> if OptGLR `elem` cli
> if OptGLR `elem` opts


%---------------------------------------
Expand All @@ -197,18 +212,18 @@ Branch off to GLR parser production

> let
> glr_decode
> | OptGLR_Decode `elem` cli = TreeDecode
> | otherwise = LabelDecode
> | OptGLR_Decode `elem` opts = TreeDecode
> | otherwise = LabelDecode
> filtering
> | OptGLR_Filter `elem` cli = UseFiltering
> | otherwise = NoFiltering
> ghc_exts = UseGhcExts
> (importsToInject opt_debug)
> | OptGLR_Filter `elem` opts = UseFiltering
> | otherwise = NoFiltering
> ghc_exts = UseGhcExts
> (importsToInject opt_debug)

Unlike below, don't always pass CPP, because only one of the files needs it.

> (langExtsToInject)
> template' <- getTemplate glrBackendDataDir cli
> template' <- getTemplate glrBackendDataDir opts
> let basename = takeWhile (/='.') outfilename
> let tbls = (action,goto)
> (parseName,_,_,_) <- case starts g of
Expand Down Expand Up @@ -241,7 +256,7 @@ Resume normal (ie, non-GLR) processing

> else do

> template' <- getTemplate lalrBackendDataDir cli
> template' <- getTemplate lalrBackendDataDir opts
> let
> template = template' ++ "/HappyTemplate.hs"

Expand All @@ -251,7 +266,7 @@ Read in the template file for this target:

and generate the code.

> magic_name <- getMagicName cli
> magic_name <- getMagicName opts
> let
> outfile = produceParser
> g
Expand Down
1 change: 1 addition & 0 deletions happy.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -114,6 +114,7 @@ extra-source-files:
tests/monad001.y
tests/monad002.ly
tests/monaderror.y
tests/Pragma.y
tests/precedence001.ly
tests/precedence002.y
tests/test_rules.y
Expand Down
8 changes: 4 additions & 4 deletions lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -651,8 +651,8 @@ MonadStuff:
> . str "\n"
> _ ->
> let
> happyParseSig =
> str "happyParse :: " . pcont . str " => " . intMaybeHash
> happyDoParseSig =
> str "happyDoParse :: " . pcont . str " => " . intMaybeHash
> . str " -> " . pty . str " " . happyAbsSyn . str "\n"
> . str "\n"
> newTokenSig =
Expand All @@ -673,7 +673,7 @@ MonadStuff:
> . str " -> Happy_IntList -> HappyStk " . happyAbsSyn
> . str " -> " . ptyAt happyAbsSyn . str ")\n"
> . str "\n"
> in happyParseSig . newTokenSig . doActionSig . reduceArrSig
> in happyDoParseSig . newTokenSig . doActionSig . reduceArrSig
> . str "happyThen1 :: " . pcont . str " => " . pty
> . str " a -> (a -> " . pty
> . str " b) -> " . pty . str " b\n"
Expand Down Expand Up @@ -750,7 +750,7 @@ have a special code path for `OldExpected`.
> . str " = "
> . str unmonad
> . str "happySomeParser where\n"
> . str " happySomeParser = happyThen (happyParse "
> . str " happySomeParser = happyThen (happyDoParse "
> . shows no . str "#"
> . maybe_tks
> . str ") "
Expand Down
2 changes: 1 addition & 1 deletion lib/data/HappyTemplate.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -48,7 +48,7 @@ data HappyStk a = HappyStk a (HappyStk a)
-----------------------------------------------------------------------------
-- starting the parse

happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
happyDoParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll

-----------------------------------------------------------------------------
-- Accepting the parse
Expand Down
7 changes: 6 additions & 1 deletion lib/frontend/boot-src/Parser.ly
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,7 @@ The parser.
> spec_errorhandlertype { TokenKW TokSpecId_ErrorHandlerType }
> spec_attribute { TokenKW TokSpecId_Attribute }
> spec_attributetype { TokenKW TokSpecId_Attributetype }
> pragma { TokenInfo $$ TokPragmaQuote }
> code { TokenInfo $$ TokCodeQuote }
> int { TokenNum $$ TokNum }
> ":" { TokenKW TokColon }
Expand All @@ -54,7 +55,7 @@ The parser.
> %%

> parser :: { BookendedAbsSyn }
> : optCode core_parser optCode { BookendedAbsSyn $1 $2 $3 }
> : optPragma optCode core_parser optCode { BookendedAbsSyn $1 $2 $3 $4 }

> core_parser :: { AbsSyn String }
> : tokInfos "%%" rules { AbsSyn (reverse $1) (reverse $3) }
Expand Down Expand Up @@ -149,6 +150,10 @@ The parser.
> : code { Just $1 }
> | {- nothing -} { Nothing }

> optPragma :: { Maybe String }
> : pragma { Just $1 }
> | {- nothing -} { Nothing }

> {
> happyError :: P a
> happyError = failP (\l -> show l ++ ": Parse error\n")
Expand Down
5 changes: 3 additions & 2 deletions lib/frontend/src/Happy/Frontend/AbsSyn.lhs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@ Here is the abstract syntax of the language we parse.

> data BookendedAbsSyn
> = BookendedAbsSyn
> (Maybe String) -- options
> (Maybe String) -- header
> (AbsSyn String)
> (Maybe String) -- footer
Expand Down Expand Up @@ -64,7 +65,7 @@ Parser Generator Directives.
ToDo: find a consistent way to analyse all the directives together and
generate some error messages.

>

> data Directive a
> = TokenType String -- %tokentype
> | TokenSpec [(a, TokenSpec)] -- %token
Expand Down Expand Up @@ -191,7 +192,7 @@ generate some error messages.
> where go code acc =
> case code of
> [] -> TokenFixed code0
>

> '"' :r -> case reads code :: [(String,String)] of
> [] -> go r ('"':acc)
> (s,r'):_ -> go r' (reverse (show s) ++ acc)
Expand Down
Loading