format-tri.tri (14012B)
1 !import format_support * 2 !import recursion as R 3 !export formatTri 4 5 -- Conservative source alignment. Token spans select exact 6 -- source cells. Head gaps and bounded repeated-call gaps may change; layout 7 -- and authored group boundaries stay put. 8 tfSlice start end input = (let rec 9 walk remaining skip count = (lazyBool 10 (_ : []) 11 (_ : case remaining of 12 [char | rest] = (lazyBool 13 (_ : pair char (walk rest 0 (pred count))) 14 (_ : walk rest (pred skip) (pred count)) 15 (isZero_? skip)) 16 _ = []) 17 (isZero_? count)) 18 in walk input start end) 19 20 tfSpaces input = (let 21 step 32 state = R.listContinue true 22 step char state = R.listStop false 23 in fst (R.listFoldUntil input true step)) 24 tfPad number = (lazyBool (_ : []) 25 (_ : pair 32 (tfPad (pred number))) (isZero_? number)) 26 27 tfMaskChar 9 = 32 28 tfMaskChar 13 = 32 29 tfMaskChar char = char 30 tfMaskLine [33 | rest] = map (_ : 32) (pair 33 rest) 31 tfMaskLine line = map tfMaskChar line 32 33 tfOpen ^sourceTokenOpen = just sourceTokenClose 34 tfOpen ^sourceTokenLeftBracket = just sourceTokenRightBracket 35 tfOpen ^sourceTokenLeftBrace = just sourceTokenRightBrace 36 tfOpen kind = nothing 37 tfClosing kind = (or? (equal? kind sourceTokenClose) 38 (or? (equal? kind sourceTokenRightBracket) (equal? kind sourceTokenRightBrace))) 39 tfDepthStep kind stack = (lazyMaybe 40 (_ : lazyBool 41 (_ : lazyList (_ : [0]) (close rest : lazyBool (_ : rest) (_ : [0]) 42 (equal? kind close)) stack) 43 (_ : stack) (tfClosing kind)) 44 (close : pair close stack) (tfOpen kind)) 45 tfDepth [] stack = stack 46 tfDepth [token | rest] stack = tfDepth rest (tfDepthStep (sourceTokenKind token) stack) 47 tfDepth input stack = [0] 48 49 -- Partition tokens by their physical source line, including newline tokens. 50 tfTokens end input = (let 51 step token tail reversed = (lazyBool 52 (_ : R.listContinue (pair token reversed)) (_ : R.listStop reversed) 53 (lt_? (sourcePositionOffset (sourceTokenStart token)) end)) 54 finish (reversed, remaining) = pair (reverse reversed) remaining 55 finish result = result 56 in finish (R.listFoldTailUntil input [] step)) 57 tfNoNewlines tokens = filter (token : not? (equal? (sourceTokenKind token) sourceTokenNewline)) tokens 58 59 tfHead input = (parserBind (sourceEquationExpect sourceTokenName) (name : 60 parserBind (parserMany sourceEquationParse) (patterns : 61 parserMap (assign : pair name (pair patterns assign)) 62 (sourceEquationExpect sourceTokenAssign))) input) 63 tfSpanCell line offset start end = (tfSlice 64 (sub (sourcePositionOffset start) offset) 65 (sub (sourcePositionOffset end) offset) line) 66 tfPatternCell line offset pattern = tfSpanCell line offset (sourceAstStart pattern) (sourceAstEnd pattern) 67 68 -- Cells include the name. Comments/tabs in inter-cell gaps preserve the row 69 -- verbatim. A whole capture's interior belongs to its cell. 70 tfGaps patterns line offset end = (let 71 step pattern previous = (lazyBool 72 (_ : R.listContinue (sub (sourcePositionOffset (sourceAstEnd pattern)) offset)) 73 (_ : R.listStop previous) 74 (tfSpaces (tfSlice previous (sub (sourcePositionOffset (sourceAstStart pattern)) offset) line))) 75 in emptyList? (snd (R.listFoldUntil patterns end step))) 76 tfLastEnd [] end = end 77 tfLastEnd [pattern | rest] end = tfLastEnd rest (sourcePositionOffset (sourceAstEnd pattern)) 78 tfLastEnd input end = end 79 80 tfWithin tokens end = (let 81 step token state = (lazyBool 82 (_ : R.listStop false) (_ : R.listContinue true) 83 (lt_? end (sourcePositionOffset (sourceTokenEnd token)))) 84 in fst (R.listFoldUntil tokens true step)) 85 86 tfParsedWith constants line offset tokens = (let 87 failed _ _ _ _ = nothing 88 parsed (name, (patterns, assign)) body _ _ = (let 89 nameEnd = sub (sourcePositionOffset (sourceTokenEnd name)) offset 90 end = sub (tfLastEnd patterns (sourcePositionOffset (sourceTokenEnd name))) offset 91 equalStart = sub (sourcePositionOffset (sourceTokenStart assign)) offset 92 populated = and? (or? constants (not? (emptyList? patterns))) (not? (emptyList? body)) 93 singleLine = and? (emptyList? (tfDepth body [])) (tfWithin tokens (add offset (length line))) 94 cleanGaps = and? (tfGaps patterns line offset nameEnd) (tfSpaces (tfSlice end equalStart line)) 95 accept ^true = (just (pair 96 (pair (tfSpanCell line offset (sourceTokenStart name) (sourceTokenEnd name)) 97 (map (tfPatternCell line offset) patterns)) 98 (tfSlice equalStart (length line) line))) 99 accept rejected = nothing 100 in accept (and? populated (and? singleLine cleanGaps))) 101 parsed _ _ _ _ = nothing 102 in parserMatchReply failed parsed (tfHead tokens)) 103 104 -- row = (original, (group name or empty, (optional cells/suffix, obstruction))). 105 tfRowWith constants line offset tokens depth = (lazyList 106 (_ : pair line (pair [] (pair nothing false))) 107 (token rest : lazyBool 108 (_ : pair line (pair (sourceTokenPayload token) 109 (pair (tfParsedWith constants line offset tokens) false))) 110 (_ : pair line (pair [] (pair nothing true))) 111 (and? (emptyList? depth) 112 (and? (equal? (sourceTokenKind token) sourceTokenName) 113 (equal? (sourcePositionOffset (sourceTokenStart token)) offset)))) tokens) 114 tfRowsWith constants rows tokens = (let rec 115 walk [] tokens offset depth = [] 116 walk [line | rest] tokens offset depth = (let end = add offset (succ (length line)) in 117 let partition = tfTokens end tokens in let located = fst partition in 118 pair (tfRowWith constants line offset (tfNoNewlines located) depth) 119 (walk rest (snd partition) end (tfDepth located depth))) 120 walk input tokens offset depth = [] 121 in walk rows tokens 0 []) 122 tfRows = tfRowsWith false 123 tfOriginal (raw, metadata) = raw 124 tfOriginal row = [] 125 tfName (raw, (name, metadata)) = name 126 tfName row = [] 127 tfCandidate (raw, (name, (candidate, obstruction))) = candidate 128 tfCandidate row = nothing 129 -- Obstructed rows keep their candidate opaque. A missing candidate is 130 -- ignorable only for nameless rows; a named unparsed head blocks the group. 131 tfEligible rows = (let rec 132 walk [] arity count = not? (lt_? count 2) 133 walk [row | rest] arity count = (let 134 inspect (_, (_, (_, ^true))) = false 135 inspect (_, (name, (candidate, ^false))) = (let 136 blank [] = walk rest arity count 137 blank name = false 138 missing _ = blank name 139 present (cells, suffix) = (let 140 size = length cells 141 accept ^true = walk rest size (succ count) 142 accept rejected = false 143 in accept (or? (isZero_? count) (equal? size arity))) 144 present candidate = false 145 in lazyMaybe missing present candidate) 146 inspect row = false 147 in inspect row) 148 walk input arity count = false 149 in walk rows 0 0) 150 tfMax a b = lazyBool (_ : b) (_ : a) (lt_? a b) 151 tfWidths [] prior = prior 152 tfWidths [cell | rest] [] = pair (length cell) (tfWidths rest []) 153 tfWidths [cell | rest] [width | widths] = pair (tfMax (length cell) width) (tfWidths rest widths) 154 tfWidths cells prior = prior 155 tfRowWidths widths row = lazyMaybe (_ : widths) (head : tfWidths (fst head) widths) (tfCandidate row) 156 tfRender [] widths suffix = suffix 157 tfRender [cell | rest] [width | widths] suffix = (append cell 158 (append (tfPad (succ (sub width (length cell)))) (tfRender rest widths suffix))) 159 tfRender cells widths suffix = suffix 160 tfRenderRow widths row = (lazyMaybe (_ : tfOriginal row) 161 (head : tfRender (fst head) widths (snd head)) (tfCandidate row)) 162 tfEmit rows = (lazyBool 163 (_ : let widths = foldl tfRowWidths [] rows in map (tfRenderRow widths) rows) 164 (_ : map tfOriginal rows) (tfEligible rows)) 165 tfGroups rows = (let rec 166 walk [] name reversed = tfEmit (reverse reversed) 167 walk [row | rest] name reversed = (lazyBool 168 (_ : walk rest name (pair row reversed)) 169 (_ : append (tfEmit (reverse reversed)) (walk rest (tfName row) [row])) 170 (or? (emptyList? (tfName row)) (equal? (tfName row) name))) 171 walk input name reversed = tfEmit (reverse reversed) 172 in walk rows [] []) 173 174 -- A second, deliberately local pass aligns adjacent distinct definition names. 175 -- Blank/comment/header/unsupported rows are barriers. Existing equation groups 176 -- keep their pattern columns. Never add more than eight padding spaces per gap. 177 tfLocalParts [name | arguments] = pair name (intercalate [32] arguments) 178 tfLocalParts cells = pair [] [] 179 tfLocalHead row = lazyMaybe (_ : pair [] []) 180 (candidate : tfLocalParts (fst candidate)) (tfCandidate row) 181 tfLocalLayout token = case sourceTokenKind token of 182 ^sourceTokenLet = true 183 ^sourceTokenWhere = true 184 ^sourceTokenDo = true 185 ^sourceTokenCase = true 186 _ = false 187 tfLocalSafe line = parserMatchReply (_ _ _ _ : false) 188 (tokens _ _ _ : not? (any? tfLocalLayout tokens)) (lexGateSource (map tfMaskChar line)) 189 tfLocalReady row = lazyMaybe (_ : false) 190 (_ : tfLocalSafe (tfOriginal row)) (tfCandidate row) 191 tfLocalUnique rows = (let rec 192 walk [] names = true 193 walk [row | rest] names = lazyBool (_ : false) 194 (_ : walk rest (pair (tfName row) names)) (lExist? (tfName row) names) 195 walk input names = false 196 in walk rows []) 197 tfLocalNameWidth width row = case tfLocalHead row of 198 (name, []) = width 199 (name, arguments) = tfMax width (length name) 200 _ = width 201 tfLocalArgumentWidth width row = tfMax width (length (snd (tfLocalHead row))) 202 tfLocalEnd width row = tfMax width (succ (length (fst (tfLocalHead row)))) 203 tfLocalWidth rows = (let 204 name = foldl tfLocalNameWidth 0 rows 205 arguments = foldl tfLocalArgumentWidth 0 rows 206 end = foldl tfLocalEnd (add name (add arguments 2)) rows 207 in pair name end) 208 tfLocalBound count = not? (lt_? 9 count) 209 tfLocalFits widths row = case tfLocalHead row of 210 (name, []) = tfLocalBound (sub (snd widths) (length name)) 211 (name, arguments) = and? (tfLocalBound (succ (sub (fst widths) (length name)))) 212 (tfLocalBound (sub (snd widths) (add (succ (fst widths)) (length arguments)))) 213 _ = false 214 215 -- Only a repeated named call's first simple argument is column-aligned. The 216 -- rest of the RHS, comments and quoting remain verbatim. Comment/tab gaps and 217 -- different call prefixes disable RHS alignment for the entire local group. 218 tfLocalAtom token = case sourceTokenKind token of 219 ^sourceTokenName = true 220 ^sourceTokenNumber = true 221 ^sourceTokenString = true 222 _ = false 223 tfLocalPrefix suffix = (let 224 inspect [assign callee argument next | rest] = (let 225 start = sourcePositionOffset (sourceTokenStart argument) 226 end = sourcePositionOffset (sourceTokenEnd argument) 227 nextStart = sourcePositionOffset (sourceTokenStart next) 228 clean = and? (tfSpaces (tfSlice (sourcePositionOffset (sourceTokenEnd callee)) start suffix)) 229 (tfSpaces (tfSlice end nextStart suffix)) 230 in lazyBool 231 (_ : just [ (tfSlice 0 start suffix) (tfSlice start end suffix) (tfSlice nextStart (length suffix) suffix) ]) 232 (_ : nothing) 233 (and? clean (and? (equal? (sourceTokenKind callee) sourceTokenName) (tfLocalAtom argument)))) 234 inspect tokens = nothing 235 in parserMatchReply (_ _ _ _ : nothing) (tokens _ _ _ : inspect tokens) (lexGateSource (map tfMaskChar suffix))) 236 tfLocalSuffix row = lazyMaybe (_ : []) snd (tfCandidate row) 237 tfLocalPrefixRow row = tfLocalPrefix (tfLocalSuffix row) 238 tfLocalBodyWidth width row = lazyMaybe (_ : width) 239 (cells : tfMax width (length (head (tail cells)))) (tfLocalPrefixRow row) 240 tfLocalBodyMatches prefix width row = lazyMaybe (_ : false) 241 (cells : and? (equal? prefix (head cells)) 242 (tfLocalBound (succ (sub width (length (head (tail cells))))))) (tfLocalPrefixRow row) 243 tfLocalBodies rows = case rows of 244 [row | rest] = lazyMaybe (_ : nothing) 245 (cells : let width = foldl tfLocalBodyWidth 0 rows in 246 lazyBool (_ : just width) (_ : nothing) 247 (not? (any? (item : not? (tfLocalBodyMatches (head cells) width item)) rows))) 248 (tfLocalPrefixRow row) 249 _ = nothing 250 tfLocalBody width row = lazyMaybe (_ : tfLocalSuffix row) 251 (size : lazyMaybe (_ : tfLocalSuffix row) 252 (cells : case cells of 253 [prefix atom rest] = append prefix (append atom 254 (append (tfPad (succ (sub size (length atom)))) rest)) 255 _ = tfLocalSuffix row) (tfLocalPrefixRow row)) width 256 tfLocalRender widths bodyWidth row = (let 257 suffix = tfLocalBody bodyWidth row 258 in case tfLocalHead row of 259 (name, []) = append name (append (tfPad (sub (snd widths) (length name))) suffix) 260 (name, arguments) = append name 261 (append (tfPad (succ (sub (fst widths) (length name)))) 262 (append arguments (append 263 (tfPad (sub (snd widths) (add (succ (fst widths)) (length arguments)))) suffix))) 264 _ = tfOriginal row) 265 tfLocalEmit rows = (let widths = tfLocalWidth rows in 266 lazyBool 267 (_ : let bodyWidth = tfLocalBodies rows in map (tfLocalRender widths bodyWidth) rows) 268 (_ : map tfOriginal rows) 269 (and? (not? (lt_? (length rows) 2)) 270 (and? (tfLocalUnique rows) (not? (any? (row : not? (tfLocalFits widths row)) rows))))) 271 tfLocalContinued [(_, (_, (_, ^true))) | rest] = true 272 tfLocalContinued rows = false 273 tfLocalGroups rows = (let rec 274 walk [] reversed = tfLocalEmit (reverse reversed) 275 walk [row | rest] reversed = lazyBool 276 (_ : walk rest (pair row reversed)) 277 (_ : append (tfLocalEmit (reverse reversed)) (pair (tfOriginal row) (walk rest []))) 278 (and? (tfLocalReady row) (not? (tfLocalContinued rest))) 279 walk input reversed = tfLocalEmit (reverse reversed) 280 in walk rows []) 281 tfLocal source = (let originalLines = lines source in 282 parserMatchReply (_ _ _ _ : source) 283 (tokens _ _ _ : intercalate [10] (tfLocalGroups (tfRowsWith true originalLines tokens))) 284 (lexGateSource (intercalate [10] (map tfMaskLine originalLines)))) 285 286 formatTri source = (let 287 originalLines = lines source 288 masked = intercalate [10] (map tfMaskLine originalLines) 289 in parserMatchReply 290 (_ _ _ _ : ok source t) 291 (tokens _ _ _ : ok (tfLocal (intercalate [10] (tfGroups (tfRows originalLines tokens)))) t) 292 (lexGateSource masked))