format-tri.tri (8032B)
1 !import format_support * 2 !import recursion as R 3 !export formatTri 4 5 -- Conservative source alignment, not an AST printer. Token spans select exact 6 -- source cells; only spaces between head cells are replaced. Layout stays put. 7 tfSlice start end input = (let rec 8 walk remaining skip count = (lazyBool 9 (_ : []) 10 (_ : case remaining of 11 [char | rest] = (lazyBool 12 (_ : pair char (walk rest 0 (pred count))) 13 (_ : walk rest (pred skip) (pred count)) 14 (isZero_? skip)) 15 _ = []) 16 (isZero_? count)) 17 in walk input start end) 18 19 tfSpaces input = (let 20 step 32 state = R.listContinue true 21 step char state = R.listStop false 22 in fst (R.listFoldUntil input true step)) 23 tfPad number = (lazyBool (_ : []) 24 (_ : pair 32 (tfPad (pred number))) (isZero_? number)) 25 26 tfMaskChar 9 = 32 27 tfMaskChar 13 = 32 28 tfMaskChar char = char 29 tfMaskLine [33 | rest] = map (_ : 32) (pair 33 rest) 30 tfMaskLine line = map tfMaskChar line 31 32 tfOpen ^sourceTokenOpen = just sourceTokenClose 33 tfOpen ^sourceTokenLeftBracket = just sourceTokenRightBracket 34 tfOpen ^sourceTokenLeftBrace = just sourceTokenRightBrace 35 tfOpen kind = nothing 36 tfClosing kind = (or? (equal? kind sourceTokenClose) 37 (or? (equal? kind sourceTokenRightBracket) (equal? kind sourceTokenRightBrace))) 38 tfDepthStep kind stack = (lazyMaybe 39 (_ : lazyBool 40 (_ : lazyList (_ : [0]) (close rest : lazyBool (_ : rest) (_ : [0]) 41 (equal? kind close)) stack) 42 (_ : stack) (tfClosing kind)) 43 (close : pair close stack) (tfOpen kind)) 44 tfDepth [] stack = stack 45 tfDepth [token | rest] stack = tfDepth rest (tfDepthStep (sourceTokenKind token) stack) 46 tfDepth input stack = [0] 47 48 -- Partition tokens by their physical source line, including newline tokens. 49 tfTokens end input = (let 50 step token tail reversed = (lazyBool 51 (_ : R.listContinue (pair token reversed)) (_ : R.listStop reversed) 52 (lt_? (sourcePositionOffset (sourceTokenStart token)) end)) 53 finish (reversed, remaining) = pair (reverse reversed) remaining 54 finish result = result 55 in finish (R.listFoldTailUntil input [] step)) 56 tfNoNewlines tokens = filter (token : not? (equal? (sourceTokenKind token) sourceTokenNewline)) tokens 57 58 tfHead input = (parserBind (sourceEquationExpect sourceTokenName) (name : 59 parserBind (parserMany sourceEquationParse) (patterns : 60 parserMap (assign : pair name (pair patterns assign)) 61 (sourceEquationExpect sourceTokenAssign))) input) 62 tfSpanCell line offset start end = (tfSlice 63 (sub (sourcePositionOffset start) offset) 64 (sub (sourcePositionOffset end) offset) line) 65 tfPatternCell line offset pattern = tfSpanCell line offset (sourceAstStart pattern) (sourceAstEnd pattern) 66 67 -- Cells include the name. Reject comments/tabs in inter-cell gaps: those are 68 -- not disposable whitespace. A whole capture's interior belongs to its cell. 69 tfGaps patterns line offset end = (let 70 step pattern previous = (lazyBool 71 (_ : R.listContinue (sub (sourcePositionOffset (sourceAstEnd pattern)) offset)) 72 (_ : R.listStop previous) 73 (tfSpaces (tfSlice previous (sub (sourcePositionOffset (sourceAstStart pattern)) offset) line))) 74 in emptyList? (snd (R.listFoldUntil patterns end step))) 75 tfLastEnd [] end = end 76 tfLastEnd [pattern | rest] end = tfLastEnd rest (sourcePositionOffset (sourceAstEnd pattern)) 77 tfLastEnd input end = end 78 79 tfWithin tokens end = (let 80 step token state = (lazyBool 81 (_ : R.listStop false) (_ : R.listContinue true) 82 (lt_? end (sourcePositionOffset (sourceTokenEnd token)))) 83 in fst (R.listFoldUntil tokens true step)) 84 85 tfParsed line offset tokens = (let 86 failed _ _ _ _ = nothing 87 parsed (name, (patterns, assign)) body _ _ = (let 88 nameEnd = sub (sourcePositionOffset (sourceTokenEnd name)) offset 89 end = sub (tfLastEnd patterns (sourcePositionOffset (sourceTokenEnd name))) offset 90 equalStart = sub (sourcePositionOffset (sourceTokenStart assign)) offset 91 populated = and? (not? (emptyList? patterns)) (not? (emptyList? body)) 92 singleLine = and? (emptyList? (tfDepth body [])) (tfWithin tokens (add offset (length line))) 93 cleanGaps = and? (tfGaps patterns line offset nameEnd) (tfSpaces (tfSlice end equalStart line)) 94 accept ^true = (just (pair 95 (pair (tfSpanCell line offset (sourceTokenStart name) (sourceTokenEnd name)) 96 (map (tfPatternCell line offset) patterns)) 97 (tfSlice equalStart (length line) line))) 98 accept rejected = nothing 99 in accept (and? populated (and? singleLine cleanGaps))) 100 parsed _ _ _ _ = nothing 101 in parserMatchReply failed parsed (tfHead tokens)) 102 103 -- row = (original, (group name or empty, (optional cells/suffix, obstruction))). 104 tfRow line offset tokens depth = (lazyList 105 (_ : pair line (pair [] (pair nothing false))) 106 (token rest : lazyBool 107 (_ : pair line (pair (sourceTokenPayload token) 108 (pair (tfParsed line offset tokens) false))) 109 (_ : pair line (pair [] (pair nothing true))) 110 (and? (emptyList? depth) 111 (and? (equal? (sourceTokenKind token) sourceTokenName) 112 (equal? (sourcePositionOffset (sourceTokenStart token)) offset)))) tokens) 113 tfRows rows tokens = (let rec 114 walk [] tokens offset depth = [] 115 walk [line | rest] tokens offset depth = (let end = add offset (succ (length line)) in 116 let partition = tfTokens end tokens in let located = fst partition in 117 pair (tfRow line offset (tfNoNewlines located) depth) 118 (walk rest (snd partition) end (tfDepth located depth))) 119 walk input tokens offset depth = [] 120 in walk rows tokens 0 []) 121 tfOriginal (raw, metadata) = raw 122 tfOriginal row = [] 123 tfName (raw, (name, metadata)) = name 124 tfName row = [] 125 tfCandidate (raw, (name, (candidate, obstruction))) = candidate 126 tfCandidate row = nothing 127 -- Obstructed rows never inspect their candidate. A missing candidate is 128 -- ignorable only for nameless rows; a named unparsed head blocks the group. 129 tfEligible rows = (let rec 130 walk [] arity count = not? (lt_? count 2) 131 walk [row | rest] arity count = (let 132 inspect (_, (_, (_, ^true))) = false 133 inspect (_, (name, (candidate, ^false))) = (let 134 blank [] = walk rest arity count 135 blank name = false 136 missing _ = blank name 137 present (cells, suffix) = (let 138 size = length cells 139 accept ^true = walk rest size (succ count) 140 accept rejected = false 141 in accept (or? (isZero_? count) (equal? size arity))) 142 present candidate = false 143 in lazyMaybe missing present candidate) 144 inspect row = false 145 in inspect row) 146 walk input arity count = false 147 in walk rows 0 0) 148 tfMax a b = lazyBool (_ : b) (_ : a) (lt_? a b) 149 tfWidths [] prior = prior 150 tfWidths [cell | rest] [] = pair (length cell) (tfWidths rest []) 151 tfWidths [cell | rest] [width | widths] = pair (tfMax (length cell) width) (tfWidths rest widths) 152 tfWidths cells prior = prior 153 tfRowWidths widths row = lazyMaybe (_ : widths) (head : tfWidths (fst head) widths) (tfCandidate row) 154 tfRender [] widths suffix = suffix 155 tfRender [cell | rest] [width | widths] suffix = (append cell 156 (append (tfPad (succ (sub width (length cell)))) (tfRender rest widths suffix))) 157 tfRender cells widths suffix = suffix 158 tfRenderRow widths row = (lazyMaybe (_ : tfOriginal row) 159 (head : tfRender (fst head) widths (snd head)) (tfCandidate row)) 160 tfEmit rows = (lazyBool 161 (_ : let widths = foldl tfRowWidths [] rows in map (tfRenderRow widths) rows) 162 (_ : map tfOriginal rows) (tfEligible rows)) 163 tfGroups rows = (let rec 164 walk [] name reversed = tfEmit (reverse reversed) 165 walk [row | rest] name reversed = (lazyBool 166 (_ : walk rest name (pair row reversed)) 167 (_ : append (tfEmit (reverse reversed)) (walk rest (tfName row) [row])) 168 (or? (emptyList? (tfName row)) (equal? (tfName row) name))) 169 walk input name reversed = tfEmit (reverse reversed) 170 in walk rows [] []) 171 172 formatTri source = (let 173 originalLines = lines source 174 masked = intercalate [10] (map tfMaskLine originalLines) 175 in parserMatchReply 176 (_ _ _ _ : ok source t) 177 (tokens _ _ _ : ok (intercalate [10] (tfGroups (tfRows originalLines tokens))) t) 178 (lexGateSource masked))