1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
|
-----------------------------------------------------------------------------
The main driver.
(c) 1993-2003 Andy Gill, Simon Marlow
GLR amendments (c) University of Durham, Ben Medlock 2001
-----------------------------------------------------------------------------
> module Main (main) where
Path settings auto-generated by Cabal:
> import Paths_happy
> import Happy.Grammar
> import Happy.Frontend
> import Happy.Frontend.AbsSyn
> import Happy.Frontend.Mangler
> import Happy.Frontend.PrettyGrammar
> import Happy.Backend.LALR
> import Happy.Backend.LALR.ProduceCode (produceParser)
> import Happy.Backend.GLR
> import Happy.Backend.GLR.ProduceCode
> import Happy.Tabular
> import Happy.Tabular.Info (genInfoFile)
> import System.Console.GetOpt
> import Control.Monad ( liftM, when, unless )
> 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 )
> main :: IO ()
> main = do
Read and parse the CLI arguments.
> args <- getArgs
> main2 args
> main2 :: [String] -> IO ()
> main2 args =
Read and parse the CLI arguments.
> case getOpt Permute argInfo (constArgs ++ args) of
> (cli,_,[]) | DumpVersion `elem` cli ->
> bye copyright
> (cli,_,[]) | DumpNumericVersion `elem` cli ->
> bye projectVersion
> (cli,_,[]) | DumpHelp `elem` cli -> do
> prog <- getProgramName
> bye (usageInfo (usageHeader prog) argInfo)
> (cli,[fl_name],[]) ->
> runParserGen cli fl_name
> (_,_,errors) -> do
> prog <- getProgramName
> die (concat errors ++
> usageInfo (usageHeader prog) argInfo)
> where
> runParserGen cliOpts fl_name = do
Open the file.
> fl <- readFile fl_name
> (name, file) <- case fileNameAndType fl_name of
> Nothing -> die ("`" ++ fl_name ++ "' does not end in `.y' or `.ly'\n")
> Just (name, Y) -> return (name, fl)
> Just (name, LY) -> return (name, deLitify fl)
Parse, using bootstrapping parser.
> (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 opts DumpMangle $ putStr $ show g
> let select_reductions | OptGLR `elem` opts = select_all_reductions
> | otherwise = select_first_reduction
> let tables = genTables select_reductions g
> sets = lr0items tables
> lainfo = (la_prop tables, la_spont tables)
> la = lookaheads tables
> goto = gotoTable tables
> action = actionTable tables
> (conflictArray,(sr,rr)) = conflicts tables
Debug output
> 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
> let (unused_rules, unused_terminals) = redundancies tables
> when (not (null unused_rules))
> (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules)))
> when (not (null unused_terminals))
> (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals)))
Print out the info file.
> info_filename <- getInfoFileName name opts
> let info = genInfoFile
> (map fst sets)
> g
> action
> goto
> conflictArray
> fl_name
> unused_rules
> unused_terminals
> version
> case info_filename of
> Just s -> do
> writeFile s info
> hPutStrLn stderr ("Grammar info written to: " ++ s)
> Nothing -> return ()
Pretty print the AbsSyn.
> pretty_filename <- getPrettyFileName name opts
> case pretty_filename of
> Just s -> do
> let out = render (ppAbsSyn abssyn)
> writeFile s out
> hPutStrLn stderr ("Production rules written to: " ++ s)
> Nothing -> return ()
Report any conflicts in the grammar.
> case expect common_options of
> Just n | n == sr && rr == 0 -> return ()
> Just _ | rr > 0 ->
> die ("The grammar has reduce/reduce conflicts.\n" ++
> "This is not allowed when an expect directive is given\n")
> Just _ ->
> die ("The grammar has " ++ show sr ++
> " shift/reduce conflicts.\n" ++
> "This is different from the number given in the " ++
> "expect directive\n")
> _ -> do
> (if sr /= 0
> then hPutStrLn stderr ("shift/reduce conflicts: " ++ show sr)
> else return ())
> (if rr /= 0
> then hPutStrLn stderr ("reduce/reduce conflicts: " ++ show rr)
> else return ())
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 opts
> opt_coerce <- getCoerce opts
> opt_strict <- getStrict opts
> opt_debug <- getDebug opts
Add any special options or imports required by the parsing machinery.
> let
> header = Just $
> (case hd of Just s -> s; Nothing -> "")
> ++ importsToInject opt_debug
> if OptGLR `elem` opts
%---------------------------------------
Branch off to GLR parser production
> then do
> let
> glr_decode
> | OptGLR_Decode `elem` opts = TreeDecode
> | otherwise = LabelDecode
> filtering
> | 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 opts
> let basename = takeWhile (/='.') outfilename
> let tbls = (action,goto)
> (parseName,_,_,_) <- case starts g of
> [s] -> return s
> s:_ -> do
> putStrLn "GLR-Happy doesn't support multiple start points (yet)"
> putStrLn "Defaulting to first start point."
> return s
> [] -> error "produceGLRParser: []"
> base <- readFile (baseTemplate template')
> lib <- readFile (libTemplate template')
> let (dat, parser) = produceGLRParser
> (base, lib) -- templates
> basename -- basename of specified output file name
> tbls -- action table (:: ActionTable)
> -- goto table (:: GotoTable)
> parseName
> header -- header from grammar spec
> tl -- trailer from grammar spec
> (opt_debug, (glr_decode,filtering,ghc_exts))
> -- controls decoding code-gen
> g -- grammar object
> common_options -- grammar object
> writeFile (basename ++ "Data.hs") dat
> writeFile (basename ++ ".hs") parser
%---------------------------------------
Resume normal (ie, non-GLR) processing
> else do
> template' <- getTemplate lalrBackendDataDir opts
> let
> template = template' ++ "/HappyTemplate.hs"
Read in the template file for this target:
> templ <- readFile template
and generate the code.
> magic_name <- getMagicName opts
> let
> outfile = produceParser
> g
> mAg
> common_options
> action
> goto
CPP is needed in all cases with unified template
> ("CPP" : langExtsToInject)
> header
> tl
> opt_coerce
> opt_strict
> defines' = defines opt_debug opt_coerce
> (if outfilename == "-" then putStr else writeFile outfilename)
> (magicFilter magic_name (outfile ++ defines' ++ templ))
Successfully Finished.
-----------------------------------------------------------------------------
> getProgramName :: IO String
> getProgramName = liftM (`withoutSuffix` ".bin") getProgName
> where str' `withoutSuffix` suff
> | suff `isSuffixOf` str' = take (length str' - length suff) str'
> | otherwise = str'
> bye :: String -> IO a
> bye s = putStr s >> exitWith ExitSuccess
> die :: String -> IO a
> die s = hPutStr stderr s >> exitWith (ExitFailure 1)
> dieHappy :: String -> IO a
> dieHappy s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
> optPrint :: [CLIFlags] -> CLIFlags -> IO () -> IO ()
> optPrint cli pass io =
> when (elem pass cli) (putStr "\n---------------------\n" >> io)
> constArgs :: [String]
> constArgs = []
------------------------------------------------------------------------------
The command line arguments.
> data CLIFlags =
> DumpMangle
> | DumpLR0
> | DumpAction
> | DumpGoto
> | DumpLA
> | DumpVersion
> | DumpNumericVersion
> | DumpHelp
> | OptInfoFile (Maybe String)
> | OptPrettyFile (Maybe String)
> | OptTemplate String
> | OptMagicName String
> | OptGhcTarget
> | OptArrayTarget
> | OptUseCoercions
> | OptDebugParser
> | OptStrict
> | OptOutputFile String
> | OptGLR
> | OptGLR_Decode
> | OptGLR_Filter
> deriving Eq
> argInfo :: [OptDescr CLIFlags]
> argInfo = [
> Option ['o'] ["outfile"] (ReqArg OptOutputFile "FILE")
> "write the output to FILE (default: file.hs)",
> Option ['i'] ["info"] (OptArg OptInfoFile "FILE")
> "put detailed grammar info in FILE",
> Option ['p'] ["pretty"] (OptArg OptPrettyFile "FILE")
> "pretty print the production rules to FILE",
> Option ['t'] ["template"] (ReqArg OptTemplate "DIR")
> "look in DIR for template files",
> Option ['m'] ["magic-name"] (ReqArg OptMagicName "NAME")
> "use NAME as the symbol prefix instead of \"happy\"",
> Option ['s'] ["strict"] (NoArg OptStrict)
> "evaluate semantic values strictly (experimental)",
> Option ['g'] ["ghc"] (NoArg OptGhcTarget)
> "use GHC extensions",
> Option ['c'] ["coerce"] (NoArg OptUseCoercions)
> "use type coercions (only available with -g)",
> Option ['a'] ["array"] (NoArg OptArrayTarget)
> "generate an array-based parser",
> Option ['d'] ["debug"] (NoArg OptDebugParser)
> "produce a debugging parser (only with -a)",
> Option ['l'] ["glr"] (NoArg OptGLR)
> "Generate a GLR parser for ambiguous grammars",
> Option ['k'] ["decode"] (NoArg OptGLR_Decode)
> "Generate simple decoding code for GLR result",
> Option ['f'] ["filter"] (NoArg OptGLR_Filter)
> "Filter the GLR parse forest with respect to semantic usage",
> Option ['?'] ["help"] (NoArg DumpHelp)
> "display this help and exit",
> Option ['V','v'] ["version"] (NoArg DumpVersion) -- ToDo: -v is deprecated
> "output version information and exit",
> Option [] ["numeric-version"] (NoArg DumpNumericVersion) -- ToDo: -v is deprecated
> "output the version number and exit",
Various debugging/dumping options...
> Option [] ["ddump-mangle"] (NoArg DumpMangle)
> "Dump mangled input",
> Option [] ["ddump-lr0"] (NoArg DumpLR0)
> "Dump LR0 item sets",
> Option [] ["ddump-action"] (NoArg DumpAction)
> "Dump action table",
> Option [] ["ddump-goto"] (NoArg DumpGoto)
> "Dump goto table",
> Option [] ["ddump-lookaheads"] (NoArg DumpLA)
> "Dump lookahead info"
> ]
------------------------------------------------------------------------------
Extract various command-line options.
> getOutputFileName :: String -> [CLIFlags] -> IO String
> getOutputFileName ip_file cli
> = case [ s | (OptOutputFile s) <- cli ] of
> [] -> return (base ++ ".hs")
> where (base, _ext) = break (== '.') ip_file
> f:fs -> return (last (f:fs))
> getInfoFileName :: String -> [CLIFlags] -> IO (Maybe String)
> getInfoFileName base cli
> = case [ s | (OptInfoFile s) <- cli ] of
> [] -> return Nothing
> [f] -> case f of
> Nothing -> return (Just (base ++ ".info"))
> Just j -> return (Just j)
> _many -> dieHappy "multiple --info/-i options\n"
> getPrettyFileName :: String -> [CLIFlags] -> IO (Maybe String)
> getPrettyFileName base cli
> = case [ s | (OptPrettyFile s) <- cli ] of
> [] -> return Nothing
> [f] -> case f of
> Nothing -> return (Just (base ++ ".grammar"))
> Just j -> return (Just j)
> _many -> dieHappy "multiple --pretty/-p options\n"
> getTemplate :: IO String -> [CLIFlags] -> IO String
> getTemplate def cli
> = case [ s | (OptTemplate s) <- cli ] of
> [] -> def
> f:fs -> return (last (f:fs))
> getMagicName :: [CLIFlags] -> IO (Maybe String)
> getMagicName cli
> = case [ s | (OptMagicName s) <- cli ] of
> [] -> return Nothing
> f:fs -> return (Just (map toLower (last (f:fs))))
> getCoerce :: [CLIFlags] -> IO Bool
> getCoerce cli = return (OptUseCoercions `elem` cli)
> getStrict :: [CLIFlags] -> IO Bool
> getStrict cli = return (OptStrict `elem` cli)
> getDebug :: [CLIFlags] -> IO Bool
> getDebug cli = return (OptDebugParser `elem` cli)
------------------------------------------------------------------------------
> projectVersion :: String
> projectVersion = showVersion version
> copyright :: String
> copyright = unlines [
> "Happy Version " ++ showVersion version ++ " Copyright (c) 1993-1996 Andy Gill, Simon Marlow (c) 1997-2005 Simon Marlow","",
> "Happy is a Yacc for Haskell, and comes with ABSOLUTELY NO WARRANTY.",
> "This program is free software; you can redistribute it and/or modify",
> "it under the terms given in the file 'LICENSE' distributed with",
> "the Happy sources."]
> usageHeader :: String -> String
> usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file\n"
-----------------------------------------------------------------------------
|
