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
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
|
module Options where
import System.Console.GetOpt
import Data.Set(Set)
import UU.Scanner.Position(Pos,noPos)
import Data.List(intercalate)
import qualified Data.Set as Set
import System.IO
import System.Exit
-- From CommonTypes
data Identifier = Ident { getName::String, getPos::Pos }
type NontermIdent = Identifier
identifier :: String -> Identifier
identifier x = Ident x noPos
instance Eq Identifier where
Ident x _ == Ident y _ = x == y
instance Ord Identifier where
compare (Ident x _) (Ident y _) = compare x y
instance Show Identifier where
show ident = getName ident
-- Make options serializable
data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String
fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options)
fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s
noOpt :: Options -> String -> [String]
noOpt _ _ = []
boolOpt :: (Options -> Bool) -> Options -> String -> [String]
boolOpt get opt strArg = let oldVal = get noOptions
newVal = get opt
in if oldVal /= newVal
then [strArg]
else []
stringOpt :: (Options -> String) -> Options -> String -> [String]
stringOpt get opt strArg = let oldVal = get noOptions
newVal = get opt
in if oldVal /= newVal
then [strArg, newVal]
else []
mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String]
mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts)
serializeOption :: Options -> MyOptDescr -> [String]
serializeOption opt (MyOpt sh ln _ get _) = get opt strArg
where
strArg = if null sh
then '-' : '-' : head ln
else '-' : head sh : []
-- All options
allOptions :: [MyOptDescr]
allOptions =
[ MyOpt ['m'] [] (NoArg (moduleOpt Nothing)) noOpt "generate default module header"
, MyOpt [] ["module"] (OptArg moduleOpt "name") moduleOptGet "generate module header, specify module name"
, MyOpt ['d'] ["data"] (NoArg dataOpt) (boolOpt dataTypes) "generate data type definition"
, MyOpt [] ["datarecords"] (NoArg dataRecOpt) (boolOpt dataRecords) "generate record data types"
, MyOpt [] ["strictdata"] (NoArg strictDataOpt) (boolOpt strictData) "generate strict data fields (when data is generated)"
, MyOpt [] ["strictwrap"] (NoArg strictWrapOpt) (boolOpt strictWrap) "generate strict wrap fields for WRAPPER generated data"
, MyOpt ['c'] ["catas"] (NoArg cataOpt) (boolOpt folds) "generate catamorphisms"
, MyOpt ['f'] ["semfuns"] (NoArg semfunsOpt) (boolOpt semfuns) "generate semantic functions"
, MyOpt ['s'] ["signatures"] (NoArg signaturesOpt) (boolOpt typeSigs) "generate signatures for semantic functions"
, MyOpt [] ["newtypes"] (NoArg newtypesOpt) (boolOpt newtypes) "use newtypes instead of type synonyms"
, MyOpt ['p'] ["pretty"] (NoArg prettyOpt) (boolOpt attrInfo) "generate pretty printed list of attributes"
, MyOpt ['w'] ["wrappers"] (NoArg wrappersOpt) (boolOpt wrappers) "generate wappers for semantic domains"
, MyOpt ['r'] ["rename"] (NoArg renameOpt) (boolOpt rename) "rename data constructors"
, MyOpt [] ["modcopy"] (NoArg modcopyOpt) (boolOpt modcopy) "use modified copy rule"
, MyOpt [] ["nest"] (NoArg nestOpt) (boolOpt nest) "use nested tuples"
, MyOpt [] ["syntaxmacro"] (NoArg smacroOpt) (boolOpt smacro) "experimental: generate syntax macro code (using knit catas)"
, MyOpt ['o'] ["output"] (ReqArg outputOpt "file") outputOptGet "specify output file"
, MyOpt ['v'] ["verbose"] (NoArg verboseOpt) (boolOpt verbose) "verbose error message format"
, MyOpt ['h','?'] ["help"] (NoArg helpOpt) (boolOpt showHelp) "get (this) usage information"
, MyOpt ['a'] ["all"] (NoArg allOpt) noOpt ("do everything (-" ++ allc ++ ")")
, MyOpt ['P'] [""] (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path")
, MyOpt [] ["prefix"] (ReqArg prefixOpt "prefix") (stringOpt prefix) "set prefix for semantic functions"
, MyOpt [] ["self"] (NoArg selfOpt) (boolOpt withSelf) "generate self attribute"
, MyOpt [] ["cycle"] (NoArg cycleOpt) (boolOpt withCycle) "check for cyclic definitions"
, MyOpt [] ["version"] (NoArg versionOpt) (boolOpt showVersion) "get version information"
, MyOpt ['O'] ["optimize"] (NoArg optimizeOpt) noOpt "optimize generated code (--visit --case)"
, MyOpt [] ["visit"] (NoArg visitOpt) (boolOpt visit) "try generating visit functions"
, MyOpt [] ["loag"] (OptArg loagOpt "Bool") (boolOpt loag) "recognises all linear ordered attribute grammars by generting a SAT problem, uses --verbose to print out numbers of clauses and variables"
, MyOpt [] ["aoag"] (NoArg aoagOpt) (boolOpt aoag) "recognises all linear ordered attribute grammars by finding fake dependencies, uses --verbose to print out the selected fake dependencies"
, MyOpt [] ["seq"] (NoArg seqOpt) (boolOpt withSeq) "force evaluation using function seq (visit functions only)"
, MyOpt [] ["unbox"] (NoArg unboxOpt) (boolOpt unbox) "use unboxed tuples"
, MyOpt [] ["bangpats"] (NoArg bangpatsOpt) (boolOpt bangpats) "use bang patterns (visit functions only)"
, MyOpt [] ["case"] (NoArg casesOpt) (boolOpt cases) "Use nested cases instead of let (visit functions only)"
, MyOpt [] ["strictcase"] (NoArg strictCasesOpt) (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)"
, MyOpt [] ["strictercase"] (NoArg stricterCasesOpt) (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)"
, MyOpt [] ["strictsem"] (NoArg strictSemOpt) (boolOpt strictSems) "Force evaluation of sem-function arguments (in generated code)"
, MyOpt [] ["localcps"] (NoArg localCpsOpt) (boolOpt localCps) "Apply a local CPS transformation (in generated code, visit functions only)"
, MyOpt [] ["splitsems"] (NoArg splitSemsOpt) (boolOpt splitSems) "Split semantic functions into smaller pieces"
, MyOpt [] ["Werrors"] (NoArg werrorsOpt) (boolOpt werrors) "Turn warnings into fatal errors"
, MyOpt [] ["Wignore"] (NoArg wignoreOpt) (boolOpt wignore) "Ignore warnings"
, MyOpt [] ["Wmax"] (ReqArg wmaxErrsOpt "<max errs reported>") wmaxErrsOptGet "Sets the maximum number of errors that are reported"
, MyOpt [] ["dumpgrammar"] (NoArg dumpgrammarOpt) (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)"
, MyOpt [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)"
, MyOpt [] ["gentraces"] (NoArg genTracesOpt) (boolOpt genTraces) "Generate trace expressions (in generated code)"
, MyOpt [] ["genusetraces"] (NoArg genUseTracesOpt) (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)"
, MyOpt [] ["gencostcentres"] (NoArg genCostCentresOpt) (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)"
, MyOpt [] ["genlinepragmas"] (NoArg genLinePragmasOpt) (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)"
, MyOpt [] ["sepsemmods"] (NoArg sepSemModsOpt) (boolOpt sepSemMods) "Generate separate modules for semantic functions (in generated code)"
, MyOpt ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files"
, MyOpt [] ["genvisage"] (NoArg genVisageOpt) (boolOpt genvisage) "Generate output for the AG visualizer Visage"
, MyOpt [] ["genmirage"] (NoArg genMirageOpt) (boolOpt genmirage) "Generate output for the AG visualizer Mirage"
, MyOpt [] ["aspectag"] (NoArg genAspectAGOpt) (boolOpt genAspectAG) "Generate AspectAG file"
, MyOpt [] ["nogroup"] (ReqArg noGroupOpt "attributes") noGroupOptGet "specify the attributes that won't be grouped in AspectAG"
, MyOpt [] ["extends"] (ReqArg extendsOpt "module") (mbStringOpt extends) "specify a module to be extended"
, MyOpt [] ["genattrlist"] (NoArg genAttrListOpt) (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)"
, MyOpt [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set"
, MyOpt [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code"
, MyOpt [] ["lckeywords"] (NoArg lcKeywordsOpt) (boolOpt lcKeywords) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)"
, MyOpt [] ["doublecolons"] (NoArg doubleColonsOpt) (boolOpt doubleColons)"Use double colons for type signatures instead of single colons"
, MyOpt ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) noOpt "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)"
, MyOpt [] ["reference"] (NoArg referenceOpt) (boolOpt reference) "Use reference attributes"
, MyOpt [] ["monadic"] (NoArg monadicOpt) (boolOpt monadic) "Experimental: generate monadic code"
, MyOpt [] ["ocaml"] (NoArg ocamlOpt) (boolOpt ocaml) "Generate Ocaml code"
, MyOpt [] ["cleanlang"] (NoArg cleanOpt) (boolOpt clean) "Generate Clean code"
, MyOpt [] ["breadthfirst"] (NoArg breadthfirstOpt) (boolOpt breadthFirst)"Experimental: generate breadth-first code"
, MyOpt [] ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy"
, MyOpt [] ["visitcode"] (NoArg visitorsOutputOpt) (boolOpt visitorsOutput) "Experimental: generate visitors code"
, MyOpt [] ["kennedywarren"] (NoArg kennedyWarrenOpt) (boolOpt kennedyWarren) "Use Kennedy-Warren's algorithm for ordering"
, MyOpt [] ["statistics"] (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE"
, MyOpt [] ["checkParseRhs"] (NoArg parseHsRhsOpt) (boolOpt checkParseRhs) "Parse RHS of rules with Haskell parser"
, MyOpt [] ["checkParseTys"] (NoArg parseHsTpOpt) (boolOpt checkParseTy) "Parse types of attrs with Haskell parser"
, MyOpt [] ["checkParseBlocks"] (NoArg parseHsBlockOpt) (boolOpt checkParseBlock) "Parse blocks with Haskell parser"
, MyOpt [] ["checkParseHaskell"] (NoArg parseHsOpt) noOpt "Parse Haskell code (recognizer)"
, MyOpt [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") nocatasOptGet "Nonterminals not to generate catas for"
, MyOpt [] ["nooptimize"] (NoArg noOptimizeOpt) (boolOpt noOptimizations) "Disable optimizations"
, MyOpt [] ["parallel"] (NoArg parallelOpt) (boolOpt parallelInvoke) "Generate a parallel evaluator (if possible)"
, MyOpt [] ["monadicwrapper"] (NoArg monadicWrappersOpt) (boolOpt monadicWrappers) "Generate monadic wrappers"
, MyOpt [] ["helpinlining"] (NoArg helpInliningOpt) (boolOpt helpInlining) "Generate inline directives for GHC"
, MyOpt [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) (boolOpt dummyTokenVisit) "Add an additional dummy parameter to visit functions"
, MyOpt [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) (boolOpt tupleAsDummyToken) "Use conventional tuples as dummy parameter instead of a RealWorld state token"
, MyOpt [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) noOpt "Use RealWorld state token as dummy parameter instead of conventional tuples (default)"
, MyOpt [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) (boolOpt strictDummyToken) "Strictify the dummy token that makes states and rules functions"
, MyOpt [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) (boolOpt noPerRuleTypeSigs) "Do not generate type sigs for attrs passed to rules"
, MyOpt [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) (boolOpt noPerStateTypeSigs) "Do not generate type sigs for attrs saved in node states"
, MyOpt [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) (boolOpt noEagerBlackholing) "Do not automatically add the eager blackholing feature for parallel programs"
, MyOpt [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) (boolOpt noPerRuleCostCentres) "Do not generate cost centres for rules"
, MyOpt [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits"
, MyOpt [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) (boolOpt noInlinePragmas) "Definitely not generate inline directives"
, MyOpt [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives"
, MyOpt [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes"
, MyOpt [] ["noincludes"] (NoArg noIncludesOpt) (boolOpt noIncludes) "Ignore include directives in .ag files"
, MyOpt [] ["quiet"] (NoArg beQuietOpt) (boolOpt beQuiet) "Dont print some compilation information"
]
-- For compatibility
options :: [OptDescr (Options -> Options)]
options = map fromMyOpt allOptions
allc :: String
allc = "dcfsprm"
data ModuleHeader = NoName
| Name String
| Default deriving (Eq, Show)
data Options = Options{ moduleName :: ModuleHeader
, dataTypes :: Bool
, dataRecords :: Bool
, strictData :: Bool
, strictWrap :: Bool
, folds :: Bool
, semfuns :: Bool
, typeSigs :: Bool
, attrInfo :: Bool
, rename :: Bool
, wrappers :: Bool
, modcopy :: Bool
, newtypes :: Bool
, nest :: Bool
, smacro :: Bool
, outputFiles :: [String]
, searchPath :: [String]
, verbose :: Bool
, prefix :: String
, withSelf :: Bool
, withCycle :: Bool
, showHelp :: Bool
, showVersion :: Bool
, visit :: Bool
, loag :: Bool
, minvisits :: Bool
, aoag :: Bool
, withSeq :: Bool
, unbox :: Bool
, bangpats :: Bool
, cases :: Bool
, strictCases :: Bool
, stricterCases :: Bool
, strictSems :: Bool
, localCps :: Bool
, splitSems :: Bool
, werrors :: Bool
, wignore :: Bool
, wmaxerrs :: Int
, dumpgrammar :: Bool
, dumpcgrammar :: Bool
, sepSemMods :: Bool
, allowSepSemMods :: Bool
, genFileDeps :: Bool
, genLinePragmas :: Bool
, genvisage :: Bool
, genmirage :: Bool
, genAspectAG :: Bool
, noGroup :: [String]
, extends :: Maybe String
, genAttributeList :: Bool
, forceIrrefutables :: Maybe String
, uniqueDispenser :: String
, lcKeywords :: Bool
, doubleColons :: Bool
, monadic :: Bool
, ocaml :: Bool
, clean :: Bool
, visitorsOutput :: Bool
, statsFile :: Maybe String
, breadthFirst :: Bool
, breadthFirstStrict :: Bool
, checkParseRhs :: Bool
, checkParseTy :: Bool
, checkParseBlock :: Bool
, nocatas :: Set NontermIdent
, noOptimizations :: Bool
, reference :: Bool
, noIncludes :: Bool
, outputStr :: String -> IO ()
, failWithCode :: Int -> IO ()
, mainFilename :: Maybe String
, beQuiet :: Bool
-- KW code path
, kennedyWarren :: Bool
, parallelInvoke :: Bool
, tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?)
, dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?)
, strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect)
, noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules
, noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state
, noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code
, lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics
, monadicWrappers :: Bool
-- tracing
, genTraces :: Bool
, genUseTraces :: Bool
, genCostCentres :: Bool
, noPerRuleCostCentres :: Bool
, noPerVisitCostCentres :: Bool
-- inline pragma generation
, helpInlining :: Bool
, noInlinePragmas :: Bool
, aggressiveInlinePragmas :: Bool
} -- deriving (Eq, Show)
noOptions :: Options
noOptions = Options { moduleName = NoName
, dataTypes = False
, dataRecords = False
, strictData = False
, strictWrap = False
, folds = False
, semfuns = False
, typeSigs = False
, attrInfo = False
, rename = False
, wrappers = False
, modcopy = False
, newtypes = False
, nest = False
, smacro = False
, outputFiles = []
, searchPath = []
, verbose = False
, showHelp = False
, showVersion = False
, prefix = "sem_"
, withSelf = False
, withCycle = False
, visit = False
, loag = False
, minvisits = False
, aoag = False
, withSeq = False
, unbox = False
, bangpats = False
, cases = False
, strictCases = False
, stricterCases = False
, strictSems = False
, localCps = False
, splitSems = False
, werrors = False
, wignore = False
, wmaxerrs = 99999
, dumpgrammar = False
, dumpcgrammar = False
, sepSemMods = False
, allowSepSemMods = True
, genFileDeps = False
, genLinePragmas = False
, genvisage = False
, genmirage = False
, genAspectAG = False
, noGroup = []
, extends = Nothing
, genAttributeList = False
, forceIrrefutables = Nothing
, uniqueDispenser = "nextUnique"
, lcKeywords = False
, doubleColons = False
, monadic = False
, ocaml = False
, clean = False
, visitorsOutput = False
, statsFile = Nothing
, breadthFirst = False
, breadthFirstStrict = False
, checkParseRhs = False
, checkParseTy = False
, checkParseBlock = False
, nocatas = Set.empty
, noOptimizations = False
, reference = False
, noIncludes = False
, outputStr = hPutStr stderr
, failWithCode = exitWith . ExitFailure
, mainFilename = Nothing
, beQuiet = False
-- defaults for the KW-code path
, kennedyWarren = False
, parallelInvoke = False
, tupleAsDummyToken = True
, dummyTokenVisit = False
, strictDummyToken = False
, noPerRuleTypeSigs = False
, noPerStateTypeSigs = False
, noEagerBlackholing = False
, lateHigherOrderBinding = False
, monadicWrappers = False
-- defaults for tracing
, genTraces = False
, genUseTraces = False
, genCostCentres = False
, noPerRuleCostCentres = False
, noPerVisitCostCentres = False
-- defaults for inline pragma generation
, helpInlining = False
, noInlinePragmas = False
, aggressiveInlinePragmas = False
}
loagOpt :: (Maybe String) -> Options -> Options
loagOpt mstr opts =
case mstr of
Nothing -> opts'
Just "0" -> opts'
Just _ -> opts' {minvisits = True}
where opts'=opts{loag = True, visit = True}
aoagOpt :: Options -> Options
aoagOpt opts =
opts{loag = True, visit = True, aoag = True}
--Options -> String -> [String]
moduleOpt :: Maybe String -> Options -> Options
moduleOpt nm opts = opts{moduleName = maybe Default Name nm}
moduleOptGet :: Options -> String -> [String]
moduleOptGet opts nm = case moduleName opts of
NoName -> []
Name s -> [nm++"="++s]
Default -> [nm]
dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genMirageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, cleanOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options
dataOpt opts = opts{dataTypes = True}
dataRecOpt opts = opts{dataRecords = True}
strictDataOpt opts = opts{strictData = True}
strictWrapOpt opts = opts{strictWrap = True}
cataOpt opts = opts{folds = True}
semfunsOpt opts = opts{semfuns = True}
signaturesOpt opts = opts{typeSigs = True}
prettyOpt opts = opts{attrInfo = True}
renameOpt opts = opts{rename = True}
wrappersOpt opts = opts{wrappers = True}
modcopyOpt opts = opts{modcopy = True}
newtypesOpt opts = opts{newtypes = True}
nestOpt opts = opts{nest = True}
smacroOpt opts = opts{smacro = True}
verboseOpt opts = opts{verbose = True}
helpOpt opts = opts{showHelp = True}
versionOpt opts = opts{showVersion = True}
prefixOpt :: String -> Options -> Options
prefixOpt pre opts = opts{prefix = pre }
selfOpt opts = opts{withSelf = True}
cycleOpt opts = opts{withCycle = True}
visitOpt opts = opts{visit = True, withCycle = True}
seqOpt opts = opts{withSeq = True}
unboxOpt opts = opts{unbox = True}
bangpatsOpt opts = opts{bangpats = True}
casesOpt opts = opts{cases = True}
strictCasesOpt opts = opts{strictCases = True}
stricterCasesOpt opts = opts{strictCases = True, stricterCases = True}
strictSemOpt opts = opts{strictSems = True}
localCpsOpt opts = opts{localCps = True}
splitSemsOpt opts = opts{splitSems = True}
werrorsOpt opts = opts{werrors = True}
wignoreOpt opts = opts{wignore = True}
wmaxErrsOpt :: String -> Options -> Options
wmaxErrsOpt n opts = opts{wmaxerrs = read n}
wmaxErrsOptGet :: Options -> String -> [String]
wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions
then [nm,show (wmaxerrs opts)]
else []
dumpgrammarOpt opts = opts{dumpgrammar = True}
dumpcgrammarOpt opts = opts{dumpcgrammar = True}
genTracesOpt opts = opts{genTraces = True}
genUseTracesOpt opts = opts{genUseTraces = True}
genCostCentresOpt opts = opts{genCostCentres = True}
sepSemModsOpt opts = opts{sepSemMods = allowSepSemMods opts}
genFileDepsOpt opts = opts{genFileDeps = True}
genLinePragmasOpt opts = opts{genLinePragmas = True}
genVisageOpt opts = opts{genvisage = True }
genMirageOpt opts = opts{genmirage = True }
genAspectAGOpt opts = opts{genAspectAG = True}
dummyTokenVisitOpt opts = opts { dummyTokenVisit = True }
tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True }
stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False }
strictDummyTokenOpt opts = opts { strictDummyToken = True }
noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True }
noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True }
noEagerBlackholingOpt opts = opts { noEagerBlackholing = True }
noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True }
noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True }
helpInliningOpt opts = opts { helpInlining = True }
noInlinePragmasOpt opts = opts { noInlinePragmas = True }
aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True }
lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True }
monadicWrappersOpt opts = opts { monadicWrappers = True }
referenceOpt opts = opts { reference = True }
noGroupOpt :: String -> Options -> Options
noGroupOpt att opts = opts{noGroup = wordsBy (== ':') att ++ noGroup opts}
noGroupOptGet :: Options -> String -> [String]
noGroupOptGet opts nm = if null (noGroup opts)
then []
else [nm, intercalate ":" (noGroup opts)]
extendsOpt :: String -> Options -> Options
extendsOpt m opts = opts{extends = Just m }
genAttrListOpt opts = opts { genAttributeList = True }
forceIrrefutableOpt :: Maybe String -> Options -> Options
forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm }
uniqueDispenserOpt :: String -> Options -> Options
uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm }
lcKeywordsOpt opts = opts { lcKeywords = True }
doubleColonsOpt opts = opts { doubleColons = True }
haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt
monadicOpt opts = opts { monadic = True }
parallelOpt opts = opts { parallelInvoke = True }
ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True }
cleanOpt opts = opts { clean = True } --TODO: More?
visitorsOutputOpt opts = opts { visitorsOutput = True }
statisticsOpt :: String -> Options -> Options
statisticsOpt nm opts = opts { statsFile = Just nm }
breadthfirstOpt opts = opts { breadthFirst = True }
breadthfirstStrictOpt opts = opts { breadthFirstStrict = True }
parseHsRhsOpt opts = opts { checkParseRhs = True }
parseHsTpOpt opts = opts { checkParseTy = True }
parseHsBlockOpt opts = opts { checkParseBlock = True }
parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt
kennedyWarrenOpt opts = opts { kennedyWarren = True }
noOptimizeOpt opts = opts { noOptimizations = True }
nocatasOpt :: String -> Options -> Options
nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where
set = Set.fromList ids
ids = map identifier lst
lst = wordsBy (== ',') str
nocatasOptGet :: Options -> String -> [String]
nocatasOptGet opts nm = if Set.null (nocatas opts)
then []
else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts]
outputOpt :: String -> Options -> Options
outputOpt file opts = opts{outputFiles = file : outputFiles opts}
outputOptGet :: Options -> String -> [String]
outputOptGet opts nm = concat [ [nm, file] | file <- outputFiles opts]
searchPathOpt :: String -> Options -> Options
searchPathOpt path opts = opts{searchPath = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts}
searchPathOptGet :: Options -> String -> [String]
searchPathOptGet opts nm = if null (searchPath opts)
then []
else [nm, intercalate ":" (searchPath opts)]
allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt
optimizeOpt = visitOpt . casesOpt
noIncludesOpt opts = opts { noIncludes = True }
beQuietOpt opts = opts { beQuiet = True }
condDisableOptimizations opts
| noOptimizations opts =
opts { strictData = False
, strictWrap = False
, withSeq = False
, unbox = False
, bangpats = False
, cases = False
, strictCases = False
, stricterCases = False
, strictSems = False
, localCps = False
, splitSems = False
, breadthFirstStrict = False
}
| otherwise = opts
-- | Inverse of intercalate
wordsBy :: (Char -> Bool) -> String -> [String]
wordsBy p = f
where
f s = let (x,xs) = break p s
in if null x then [] else x : f (drop 1 xs)
-- | Use all parsed options to generate real options
constructOptions :: [Options -> Options] -> Options
constructOptions = foldl (flip ($)) noOptions
-- | Create Options type from string arguments
getOptions :: [String] -> (Options,[String],[String])
getOptions args = let (flags,files,errors) = getOpt Permute options args
appliedOpts = constructOptions flags
finOpts = condDisableOptimizations appliedOpts
in (finOpts,files,errors)
-- | Convert options back to commandline string
optionsToString :: Options -> [String]
optionsToString opt = concatMap (serializeOption opt) allOptions
-- | Combine 2 sets of options
combineOptions :: Options -> Options -> Options
combineOptions o1 o2 = let str1 = optionsToString o1
str2 = optionsToString o2
(opt,_,_) = getOptions (str1 ++ str2)
in opt
|
