staged_conditional.py (18945B)
1 #!/usr/bin/env python3 2 """Opt-in staged conditional source profile, focused Haskell-only source fixtures.""" 3 import argparse 4 import contextlib 5 import json 6 from pathlib import Path 7 from research_session import ResearchSession 8 import re 9 import subprocess 10 import tempfile 11 12 ROOT = Path(__file__).resolve().parent.parent 13 parser = argparse.ArgumentParser(description=__doc__) 14 parser.add_argument('tricu', type=Path) 15 parser.add_argument('--compiler-bundle', type=Path, required=True) 16 parser.add_argument('--prepared', type=Path, action='append', required=True) 17 parser.add_argument('--support-bundle', type=Path) 18 parser.add_argument('--directory', type=Path) 19 parser.add_argument('--source-only', action='store_true') 20 parser.add_argument('--case', action='append', default=[], help='focused named cases; negative controls still run') 21 scope = parser.add_mutually_exclusive_group() 22 scope.add_argument('--list-only', action='store_true') 23 scope.add_argument('--newlines-only', action='store_true') 24 args = parser.parse_args() 25 tricu = str(args.tricu.resolve()) 26 27 28 def run(command, *, seconds=1200): 29 return session.run(command, seconds)[0] 30 31 32 manager = contextlib.nullcontext(args.directory.resolve()) if args.directory else tempfile.TemporaryDirectory(prefix='.stage-if-', dir=ROOT / 'test') 33 with manager as directory: 34 root = Path(directory).resolve() 35 assert root.is_relative_to(ROOT) 36 root.mkdir(parents=True, exist_ok=True) 37 session = ResearchSession(tricu, root, args.prepared, args.compiler_bundle) 38 store = session.store 39 def compile(source, names, output): 40 return session.compile(source, names, output) 41 def imported(bundle, indexed=True): 42 reply = run([tricu, 'arboricx', 'import', '--file', str(bundle), '--store', str(store), 43 *(['--indexed'] if indexed else ['--flat'])]) 44 pin = re.search(rb'Created module alias .* -> ([0-9a-f]{64})', reply)[1].decode() 45 manifest = (store / 'objects' / pin[:3] / pin).read_text() 46 return pin, pin + ':' + manifest.splitlines()[1].split('\t')[1] 47 48 lower = root / 'lower.arboricx' 49 compile(ROOT / 'lib/source/staging-experiment.tri', ['stageBody', 'stageBranch', 'stageBody_', 'stageShift_', 'stageFinish', 'stageThunk', 'stageRecur'], lower) 50 lower_pin, _ = imported(lower) 51 list_source = ROOT / 'lib/source/staged-list-experiment.tri' 52 list_compiler = root / 'list-compiler.arboricx' 53 compile(list_source, ['stagedListRewrite', 'stagedListBindings', 'stagedListMarker', 'stagedNextMarker'], list_compiler) 54 list_pin, _ = imported(list_compiler) 55 source = ROOT / 'lib/source/staged-conditional-experiment.tri' 56 compiler = root / 'compiler.arboricx' 57 compile(source, ['stagedIfCompileDefinitions'], compiler) 58 compiler_pin, _ = imported(compiler) 59 runner_source = ROOT / 'test/stagedConditionalRunner.tri' 60 runner = root / 'runner.arboricx' 61 compile(runner_source, ['matches', 'ordinarySame'], runner) 62 runner_pin, _ = imported(runner, indexed=True) 63 construction = root / 'construction.arboricx' 64 compile(runner_source, ['constructionReady'], construction) 65 construction_pin, _ = imported(construction, indexed=True) 66 published_runner = root / 'published-runner.arboricx' 67 compile(runner_source, ['matchesPublished'], published_runner) 68 published_runner_pin, _ = imported(published_runner, indexed=True) 69 environment = '[(pair "true" true) (pair "false" false) (pair "pair" pair) (pair "triage" triage) (pair "y" y) (pair "fst" fst) (pair "snd" snd) (pair "pred" pred) (pair "isZero_?" isZero_?) (pair "lt_?" lt_?) (pair "succ" succ) (pair "equal?" equal?) (pair "and?" and?)]' 70 spin = 'spin self input = triage 7 (_ : 7) (left right : self input) input\nloop input = y spin input\n' 71 cases = [ 72 ('yes', 'main condition value = stageIf condition value 0\n', '[true 23]', True, '23'), 73 ('no', 'main condition value = stageIf condition value 0\n', '[false 23]', True, '0'), 74 ('closed-unselected', spin + 'main = stageIf false (loop [1]) 23\n', '[]', True, '23'), 75 ('closed-under-parameter', spin + 'main c = stageIf c (loop [1]) 23\n', '[false]', True, '23'), 76 ('nested', spin + 'main c x = stageIf c (stageIf false (loop [1]) x) 0\n', '[true 23]', True, '23'), 77 ('closure', 'main c saved = stageIf c (fresh : pair saved fresh) (fresh : fresh)\n', '[true 11 12]', True, '(pair 11 12)'), 78 ('fourth-argument', 'main = stageIf true (x : x) (x : 0) 23\n', '[]', True, '23'), 79 ('local-shadow', 'main = (stageIf : stageIf 23 24 25) (a b c : a)\n', '[]', True, '23'), 80 ('let-shadow', 'main = let stageIf a b c = a in stageIf 23 24 25\n', '[]', True, '23'), 81 ('ordinary', 'main x = pair x x\n', '[23]', True, '(pair 23 23)'), 82 ('import-shadow', 'pair a b = t\nmain = 23\n', '[]', False, '"pair"'), 83 ('zero-args', 'main = stageIf\n', '[]', False, '"fully applied stageIf condition yes no"'), 84 ('one-arg', 'main = stageIf true\n', '[]', False, '"fully applied stageIf condition yes no"'), 85 ('two-args', 'main = stageIf true 23\n', '[]', False, '"fully applied stageIf condition yes no"'), 86 ('escape', 'main f = f stageIf\n', '[]', False, '"fully applied stageIf condition yes no"'), 87 ('top-shadow', 'stageIf a b c = a\nmain = 23\n', '[]', False, '"stageIf"'), 88 ('marker-collision', 'main = "tricu.experimental.stageIf.v1"\n', '[]', False, '"reserved stageIf marker value"'), 89 ('environment-name', 'main = 23\n', '[]', False, 90 '"stageIf is an experimental compiler binding"', '[(pair "stageIf" t)]'), 91 ('environment-marker', 'main = 23\n', '[]', False, 92 '"stageIf is an experimental compiler binding"', 93 '[(pair "alias" "tricu.experimental.stageIf.v1")]'), 94 ] 95 list_cases = [ 96 ('list-empty', 'main xs = stageList xs 23 (state : state) (head state : stageNext state)\n', '[[]]', True, '23'), 97 ('list-advance', 'main xs = stageList xs [] (state : state) (head state : stageNext (pair head state))\n', '[[1 2 3]]', True, '[3 2 1]'), 98 ('list-map', 'main xs = stageList xs [] (state : state) (head state : pair head (stageNext state))\n', '[[1 2 3]]', True, '[1 2 3]'), 99 ('list-stop', 'main xs = stageList xs 23 (state : state) (head state : state)\n', '[[1 2 3]]', True, '23'), 100 ('list-malformed', 'main xs = stageList xs 23 (state : state) (head state : 0)\n', '[(t t)]', True, '23'), 101 ('list-outer', 'main saved xs = stageList xs 0 (state : saved) (head state : pair saved (stageNext state))\n', '[11 [1 2]]', True, '(pair 11 (pair 11 11))'), 102 ('list-closure', 'main saved xs = stageList xs 0 (state : fresh : pair saved fresh) (head state : fresh : pair head (stageNext state fresh))\n', '[11 [1 2] 12]', True, '(pair 1 (pair 2 (pair 11 12)))'), 103 ('list-closed-done', spin + 'main xs = stageList xs 0 (state : loop [1]) (head state : 23)\n', '[[1]]', True, '23'), 104 ('list-closed-step', spin + 'main xs = stageList xs 23 (state : state) (head state : loop [1])\n', '[[]]', True, '23'), 105 ('next-outside', 'main = stageNext 23\n', '[]', False, '"stageNext belongs only to a stageList step body"'), 106 ('next-done', 'main xs = stageList xs 0 (state : stageNext state) (head state : 23)\n', '[[]]', False, '"stageNext belongs only to a stageList step body"'), 107 ('next-state', 'main xs = stageList xs 0 (state : state) (head state : stageNext (stageNext state))\n', '[[]]', False, '"stageNext belongs only to a stageList step body"'), 108 ('list-bare', 'main = stageList\n', '[]', False, '"fully applied stageList input state done step or stageNext state"'), 109 ('list-callback', 'main xs = stageList xs 0 23 (head state : 23)\n', '[[]]', False, '"stageList done requires an inline state binder"'), 110 ] 111 slice_source = '\n'.join(line for line in (ROOT / 'test/stagedFormatterSlice.tri').read_text().splitlines() 112 if not line.startswith('--')) + '\n' 113 list_cases += [ 114 ('slice-basic', slice_source + 'main = tfSlice 1 4\n', '["abcdef"]', True, '"bcd"'), 115 ('slice-zero', slice_source + 'main = tfSlice 0 0\n', '["abcdef"]', True, '[]'), 116 ('slice-known', slice_source + 'main = tfSlice 0 3\n', '["abcdef"]', True, '"abc"'), 117 ('slice-empty', slice_source + 'main = tfSlice 0 3\n', '[[]]', True, '[]'), 118 ('slice-unicode', slice_source + 'main = tfSlice 1 4\n', '["λ猫abc"]', True, '"猫ab"'), 119 ('slice-malformed', slice_source + 'main = tfSlice 0 3\n', '[(t t)]', True, '[]'), 120 ('slice-past', slice_source + 'main = tfSlice 8 10\n', '["abc"]', True, '[]'), 121 ('slice-truncate', slice_source + 'main = tfSlice 1 9\n', '["abc"]', True, '"bc"'), 122 ('slice-reversed', slice_source + 'main = tfSlice 4 2\n', '["abcdef"]', True, '[]'), 123 ('unused-head', spin + 'main = stageList (pair (loop [1]) []) 0 (state : 23) (head state : 23)\n', '[]', True, '23'), 124 ('unused-tail', spin + 'main = stageList (pair 1 (loop [1])) 0 (state : 23) (head state : 23)\n', '[]', True, '23'), 125 ('next-condition', 'main xs = stageList xs 0 (state : state) (head state : stageIf (stageNext state) 0 1)\n', '[[]]', False, '"stageNext belongs only to a stageList step body"'), 126 ('nested-list', 'main xs = stageList xs 0 (state : state) (head state : stageList [] 0 (s : s) (h s : s))\n', '[[]]', False, '"nested stageList is not supported in callbacks"'), 127 ] 128 # Resolve the demo's declared text_support dependency to a verified, 129 # name-explicit manifest. The unit profile receives only these five trees. 130 text_support_source = root / 'text-support.tri' 131 text_support_source.write_text(chr(33) + 'import "prelude" ' + chr(33) + 'Local\n') 132 text_support = root / 'text-support.arboricx' 133 text_names = ['pair', 'true', 'false', 'and?', 'equal?'] 134 compile(text_support_source, text_names, text_support) 135 text_support_pin, _ = imported(text_support) 136 text_environment = '[' + ' '.join(f'(pair {json.dumps(name)} N.{name})' for name in text_names) + ']' 137 (root / 'text_support.tri').write_text(chr(33) + f'export * from {text_support_pin}\n') 138 demo = (ROOT / 'demos/staged-newlines/app.tri').read_text() 139 assert demo.splitlines()[:2] == ['!import text_support *', '!export normalizeNewlines'] 140 newline_source = '\n'.join(line for line in (ROOT / 'demos/staged-newlines/app.tri').read_text().splitlines() 141 if not line.startswith(chr(33))) + '\nmain = normalizeNewlines\n' 142 newline_inputs = ['', 'plain λ猫 text', '\n', '\r', '\r\n', '\r\r\n', '\n\r', 143 'a\r\nb\rc\nd', '\rstart', 'end\r', 'a\r\n\r\nb', 144 'λ\r\n猫\r🌲', '-- comment\r\nf x = "a"\r', 'a' * 128 + '\r\n' + 'b' * 128] 145 newline_cases = [(f'newlines-{i}', newline_source, 146 '[' + json.dumps(text, ensure_ascii=False) + ']', True, 147 json.dumps(text.replace('\r\n', '\n').replace('\r', '\n'), ensure_ascii=False), text_environment) 148 for i, text in enumerate(newline_inputs)] 149 newline_cases += [('newlines-idempotent', newline_source.replace('main = normalizeNewlines', 150 'main text = equal? (normalizeNewlines (normalizeNewlines text)) (normalizeNewlines text)'), 151 '[' + json.dumps('a\r\nλ\r\r\n猫\nend\r', ensure_ascii=False) + ']', True, 'true', text_environment)] 152 cases = newline_cases if args.newlines_only else list_cases if args.list_only else cases + list_cases + newline_cases 153 if args.case: 154 wanted = set(args.case) 155 selected = [entry for entry in cases if entry[0] in wanted] 156 if {entry[0] for entry in selected} != wanted: 157 raise ValueError('unknown case selection') 158 cases = selected 159 fixture_source = root / 'fixture.tri' 160 fixture_bundle = root / 'fixture.arboricx' 161 def expression(text, arguments, success, expected, env=environment): 162 value = (f'pair {env} (pair {json.dumps(text)} ' 163 f'(pair {arguments} (pair {"true" if success else "false"} {expected})))') 164 # Fixture authoring transports Unicode scalar cells explicitly. This 165 # is data construction, not a replacement for source-language decoding. 166 def scalar_literal(match): 167 text = json.loads(match.group()) 168 return '[' + ' '.join(str(ord(c)) for c in text) + ']' if any(ord(c)>127 for c in text) else match.group() 169 return re.sub(r'"(?:[^"\\]|\\.)*"', scalar_literal, value) 170 all_entries = cases + [('wrong-output', 'main = 23\n', '[]', True, '24')] 171 specifications = [expression(entry[1], entry[2], entry[3], entry[4], entry[5] if len(entry)>5 else environment) 172 for entry in all_entries] 173 specifications += [expression(spin + 'main = stageIf true (loop [1]) 23\n', '[]', True, '23'), 174 expression(spin + 'choose c yes no = stageIf c yes no\nmain c = choose c (loop [1]) 23\n', 175 '[false]', True, '23')] 176 specifications = list(dict.fromkeys(specifications)) 177 fixture_source.write_text('!import prelude *\n' + 178 f'!import {text_support_pin} as N\n!export *\n' + 179 ''.join(f'fixture_{index} = {value}\n' for index, value in enumerate(specifications))) 180 batch_bundle = root / 'fixture-batch.arboricx' 181 compile(fixture_source, [f'fixture_{i}' for i in range(len(specifications))], batch_bundle) 182 batch_pin, _ = imported(batch_bundle) 183 rows = session.object('arboricx.module-manifest.v1', batch_pin).decode().splitlines()[1:] 184 batch_exports = {row.split('\t')[1]: row.split('\t')[3] for row in rows} 185 def fixture_for(text, arguments, success, expected, env=environment): 186 index = specifications.index(expression(text, arguments, success, expected, env)) 187 tree = batch_exports[f'fixture_{index}'] 188 run([tricu, 'arboricx', 'export', '--store', str(store), '--target', tree, 189 '--name', 'fixture', '--output', str(fixture_bundle)]) 190 return batch_pin + f':fixture_{index}' 191 for entry in cases + [('wrong-output', 'main = 23\n', '[]', True, '24')]: 192 name, text, arguments, success, expected, *custom_environment = entry 193 fixture_tree = fixture_for(text, arguments, success, expected, 194 custom_environment[0] if custom_environment else environment) 195 h = run([tricu, 'arboricx', 'run', '--store', str(store), '--module', runner_pin, 196 '--name', 'matches', '--arg-export', fixture_tree, '--format', 'tree']) 197 valid = name != 'wrong-output' 198 assert h.strip() == (b't t' if valid else b't'), (name, h) 199 print(f'{name}: Haskell source compiler passes', flush=True) 200 if success and valid: 201 h = run([tricu, 'arboricx', 'run', '--store', str(store), '--module', construction_pin, 202 '--name', 'constructionReady', '--arg-export', fixture_tree, '--format', 'tree']) 203 assert h.strip() == b't t', (name, 'construction', h) 204 if name.startswith(('slice-', 'newlines-')): 205 # Independently verify publication and execution of emitted code. 206 fixture_pin, _ = imported(fixture_bundle) 207 driver = root / 'published-driver.tri' 208 driver.write_text(chr(33) + f'import "{compiler_pin}" P\n' + chr(33) + 209 f'import "{fixture_pin}" F\n' + chr(33) + 'import "prelude" !Local\n' + chr(33) + 210 'import "source.resolve" !Local\n' + chr(33) + 'import "parser" !Local\n' + 211 'compiled = P.stagedIfCompileDefinitions (fst F.fixture) (fst (snd F.fixture))\n' 212 'main = lazyResult (_ _ : t) (defs _ : lazyMaybe (_ : t) (fn : fn) ' 213 '(sourceFindExternal defs "main")) compiled\n' 214 'stagedStatus = lazyResult (problem _ : parserDiagnosticExpected problem) (_ _ : "compiled") compiled\n') 215 code = root / 'published.arboricx' 216 exports = ['main', 'stagedStatus'] 217 if name.startswith('newlines-'): 218 with driver.open('a') as output: 219 output.write('normalizeNewlines = lazyResult (_ _ : t) (defs _ : ' 220 'lazyMaybe (_ : t) (fn : fn) (sourceFindExternal defs "normalizeNewlines")) compiled\n') 221 exports.append('normalizeNewlines') 222 compile(driver, exports, code) 223 code_pin, _ = imported(code, indexed=True) 224 status = run([tricu, 'arboricx', 'run', '--store', str(store), '--module', code_pin, 225 '--name', 'stagedStatus', '--format', 'string']) 226 assert status.strip() == b'"compiled"', status 227 _, main_tree = imported(code) 228 result = run([tricu, 'arboricx', 'run', '--store', str(store), 229 '--module', published_runner_pin, '--name', 'matchesPublished', 230 '--arg-export', main_tree, '--arg-export', fixture_tree, '--format', 'tree']) 231 assert result.strip() == b't t', (name, 'published execution', result) 232 print(f'{name}: published code executes correctly on Haskell', flush=True) 233 if name in ['ordinary', 'local-shadow', 'let-shadow', 'import-shadow']: 234 h = run([tricu, 'arboricx', 'run', '--store', str(store), '--module', runner_pin, 235 '--name', 'ordinarySame', 236 '--arg-export', fixture_tree, '--format', 'tree']) 237 assert h.strip() == b't t', (name, h) 238 print(f'{name}: canonical tree equality on Haskell', flush=True) 239 fixture_tree = fixture_for(spin + 'main = stageIf true (loop [1]) 23\n', '[]', True, '23') 240 try: 241 run([tricu, 'arboricx', 'run', '--store', str(store), '--module', runner_pin, 242 '--name', 'matches', '--arg-export', fixture_tree, 243 '--format', 'tree'], seconds=2) 244 raise AssertionError('selected closed work unexpectedly returned') 245 except subprocess.TimeoutExpired: 246 print('selected closed work: bounded Haskell timeout', flush=True) 247 # A source construct owns caller expression syntax. Wrapping it in an 248 # ordinary function cannot make that function's arguments staged syntax. 249 fixture_tree = fixture_for(spin + 250 'choose c yes no = stageIf c yes no\nmain c = choose c (loop [1]) 23\n', 251 '[false]', True, '23') 252 try: 253 run([tricu, 'arboricx', 'run', '--store', str(store), '--module', construction_pin, 254 '--name', 'constructionReady', '--arg-export', fixture_tree, 255 '--format', 'tree'], seconds=2) 256 raise AssertionError('ordinary wrapper unexpectedly protected caller syntax') 257 except subprocess.TimeoutExpired: 258 print('ordinary-wrapper negative control: construction timeout', flush=True) 259 # Formatter integration is a separate explicit job, not an implicit 260 # campaign after the research harness has consumed its runtime budget.