format.tri (12380B)
1 !import prelude * 2 !import parser as P 3 !import lexer as L 4 !import consumers_source as C 5 !export * 6 -- Source-preserving SCP column alignment. This is a syntax walker, not an 7 -- authored-IR printer: names, literal spellings and comments stay in source. 8 9 -- An anchor is (location, structural key). Paths distinguish corresponding 10 -- separators, not ordinal occurrences (a nested call cannot steal an outer as). 11 fFlatten_ self lists = (lazyList (_ : t) 12 (head rest : append head (self rest)) lists) 13 fFlatten lists = y fFlatten_ lists 14 fPosition = P.parserMap C.cStart P.parserPeek 15 fSkip kind = P.parserMap (_ : t) (C.cExpect kind) 16 fWord word = P.parserMap (_ : t) (C.cWord word) 17 fAnchor kind key = (P.parserBind fPosition (location : 18 P.parserMap (_ : [(pair location key)]) (C.cExpect kind))) 19 fAs key = (P.parserBind fPosition (location : 20 P.parserMap (_ : [(pair location key)]) (C.cWord "as"))) 21 fJoin left right = P.parserBind left (a : P.parserMap (b : append a b) right) 22 23 -- Pattern recognition deliberately does not bind captures or validate names. 24 fPattern_ self input = (lazyList 25 (_ : P.parserFailure (C.cExpected "pattern" t t) input) 26 (token rest : lazyBool 27 (_ : P.parserBind (C.cExpect C.cName) (name : lazyBool 28 (_ : self) (_ : lazyBool 29 (_ : P.parserThen (C.cExpect C.cName) self) 30 (_ : P.parserPure t) (equal? name "as")) 31 (equal? name "stem")) input) 32 (_ : lazyBool (_ : fSkip C.cNumber input) 33 (_ : lazyBool (_ : fSkip C.cString input) 34 (_ : lazyBool 35 (_ : P.parserThen (fSkip C.cOpen) 36 (P.parserThen self (P.parserThen (fSkip C.cComma) 37 (P.parserBefore self (fSkip C.cClose)))) input) 38 (_ : P.parserThen (fSkip C.cLeft) (P.parserOr 39 (fSkip C.cRight) (P.parserThen self 40 (P.parserThen (fSkip C.cBar) 41 (P.parserBefore self (fSkip C.cRight))))) input) 42 (equal? (C.cKind token) C.cOpen)) 43 (equal? (C.cKind token) C.cString)) 44 (equal? (C.cKind token) C.cNumber)) 45 (equal? (C.cKind token) C.cName)) input) 46 fPattern input = y fPattern_ input 47 48 fPair output path close separator = (fJoin 49 (output (pair 0 path)) 50 (P.parserThen (fSkip separator) 51 (P.parserBefore (output (pair 1 path)) (fSkip close)))) 52 fRecur output path = (fJoin (output (pair 0 path)) 53 (fJoin (fAnchor C.cAt (pair 3 path)) (output (pair 1 path)))) 54 fBecome output path = (fJoin (output (pair 0 path)) 55 (fJoin (output (pair 1 path)) 56 (fJoin (fAnchor C.cAt (pair 4 path)) (output (pair 2 path))))) 57 fCall output path = (fJoin (output (pair 0 path)) 58 (fJoin (output (pair 1 path)) 59 (fJoin (fAs (pair 5 path)) 60 (P.parserThen (C.cExpect C.cName) 61 (P.parserThen (fWord "in") (output (pair 2 path))))))) 62 fArm output path = (P.parserThen fPattern 63 (P.parserThen (fSkip C.cArrow) (output (pair 0 path)))) 64 fMatch output path = (fJoin (output (pair 0 path)) 65 (P.parserThen (fWord "of") (P.parserThen (fSkip C.cOpen) 66 (P.parserBefore (P.parserBind (fArm output (pair 1 path)) (first : 67 P.parserMap (rest : fScopes (pair first rest)) 68 (P.parserMany (P.parserThen (fSkip C.cBar) 69 (fArm output (pair 1 path)))))) (fSkip C.cClose))))) 70 fCoreName output path name = (lazyBool 71 (_ : fRecur output path) 72 (_ : lazyBool (_ : fBecome output path) 73 (_ : lazyBool (_ : fCall output path) 74 (_ : lazyBool (_ : fMatch output path) 75 (_ : lazyBool (_ : fJoin (output (pair 0 path)) 76 (fJoin (output (pair 1 path)) (output (pair 2 path)))) 77 (_ : lazyBool (_ : fJoin (output (pair 0 path)) (output (pair 1 path))) 78 (_ : lazyBool (_ : output (pair 0 path)) 79 (_ : P.parserMap (_ : t) (P.parserMany 80 (P.parserThen (fSkip C.cDot) (C.cExpect C.cName)))) 81 (equal? name "stem")) (equal? name "equal")) 82 (equal? name "choose")) (equal? name "match")) 83 (equal? name "call")) (equal? name "become")) (equal? name "recur")) 84 fName output outer name = (let path = pair name outer in (lazyBool 85 (_ : fJoin (output (pair 0 path)) 86 (fJoin (output (pair 1 path)) (output (pair 2 path)))) 87 (_ : lazyBool 88 (_ : P.parserThen (fWord "read") 89 (fJoin (output (pair 0 path)) (fJoin (output (pair 1 path)) 90 (P.parserThen (fWord "resume") (P.parserThen (C.cExpect C.cName) 91 (fJoin (fAnchor C.cAt (pair 7 path)) (output (pair 2 path)))))))) 92 (_ : fCoreName output path name) (equal? name "await")) 93 (equal? name "reply"))) 94 fOutput_ self input path = (lazyList 95 (_ : P.parserFailure (C.cExpected "output" t t) input) 96 (token rest : let output = child : stream : self stream child in 97 lazyBool 98 (_ : P.parserBind (C.cExpect C.cName) (name : fName output path name) input) 99 (_ : lazyBool (_ : fSkip C.cNumber input) 100 (_ : lazyBool (_ : fSkip C.cString input) 101 (_ : lazyBool 102 (_ : P.parserThen (fSkip C.cOpen) 103 (fPair output (pair 8 path) C.cClose C.cComma) input) 104 (_ : P.parserThen (fSkip C.cLeft) (P.parserOr 105 (fSkip C.cRight) (fPair output (pair 9 path) C.cRight C.cBar)) input) 106 (equal? (C.cKind token) C.cOpen)) 107 (equal? (C.cKind token) C.cString)) 108 (equal? (C.cKind token) C.cNumber)) 109 (equal? (C.cKind token) C.cName)) input) 110 fOutput path input = y fOutput_ input path 111 -- The route frontend has a deliberately bounded input spelling. 112 fInput input = (P.parserBind P.parserPeek (token : lazyBool 113 (_ : P.parserThen (fWord "GET") (P.parserThen (C.cExpect C.cString) 114 (P.parserMap (_ : t) (P.parserOr (C.cExpect C.cName) (P.parserPure t))))) 115 (_ : lazyBool 116 (_ : P.parserThen (C.cExpect C.cName) (fSkip C.cName)) 117 (_ : fPattern) 118 (or? (equal? (C.cPayload token) "Ok") (equal? (C.cPayload token) "Err"))) 119 (equal? (C.cPayload token) "GET")) input) 120 fRule = (P.parserBind fPosition (start : P.parserMap 121 (anchors : pair (pair start [99]) anchors) 122 (P.parserThen fInput 123 (fJoin (fAnchor C.cAt [0]) (P.parserThen fPattern 124 (fJoin (fAnchor C.cArrow [1]) (fOutput [2]))))))) 125 fDeclaration? tokens = (lazyList (_ : false) 126 (token rest : and? (equal? (C.cKind token) C.cName) 127 (equal? (C.cPayload token) "consumer")) tokens) 128 fNextRule input = (lazyBool 129 (_ : P.parserFailure (C.cExpected "rule" "consumer" t) input) 130 (_ : fRule input) (fDeclaration? input)) 131 fDefinition = (P.parserThen (fWord "consumer") 132 (P.parserThen (C.cExpect C.cName) 133 (P.parserMap (rules : fFlatten rules) (P.parserSome fNextRule)))) 134 fDefinitions = P.parserBefore (P.parserMany fDefinition) P.parserEof 135 136 -- Mask declaration header lines, retaining every original position. Formatting 137 -- never resolves imports or requires their targets to be installed. 138 fMaskLine line = (lazyList (_ : line) 139 (char rest : lazyBool (_ : map (c : lazyBool (_ : c) (_ : 32) 140 (equal? c 13)) line) (_ : line) (equal? char 33)) 141 (dropWhile trimByte? line)) 142 fHeader? line = (lazyList (_ : false) 143 (char rest : equal? char 33) (dropWhile trimByte? line)) 144 fComment? line = (lazyList (_ : false) 145 (char rest : lazyList (_ : false) 146 (next tail : and? (equal? char 45) (equal? next 45)) rest) 147 (dropWhile trimByte? line)) 148 fMaskedLines_ self rows = (lazyList (_ : t) 149 (line rest : lazyBool 150 (_ : pair (fMaskLine line) (self rest)) 151 (_ : lazyBool (_ : pair line (self rest)) (_ : rows) 152 (or? (fComment? line) (emptyList? (dropWhile C.cSpace? line)))) 153 (fHeader? line)) rows) 154 fMaskedLines rows = y fMaskedLines_ rows 155 fMasked source = intercalate [10] (fMaskedLines (lines source)) 156 157 -- Split a physical source line at its anchors. Each piece stores its exact 158 -- source text and the key of the separator immediately following it. 159 fRTrim text = reverse (dropWhile trimByte? (reverse text)) 160 fPieces_ self text anchors column reversed = (lazyList 161 (_ : [(pair (append (reverse reversed) text) nothing)]) 162 (anchor rest : lazyBool 163 (_ : pair (pair (fRTrim (reverse reversed)) (just (snd anchor))) 164 (self text rest column t)) 165 (_ : lazyList 166 (_ : [(pair (reverse reversed) nothing)]) 167 (char tail : self tail anchors (succ column) (pair char reversed)) text) 168 (equal? column (L.lexerPositionColumn (fst anchor)))) anchors) 169 fPieces text anchors = y fPieces_ text anchors 1 t 170 fOnLine anchors line = filter (a : equal? (L.lexerPositionLine (fst a)) line) anchors 171 fIndent pieces = (lazyList (_ : t) 172 (piece rest : pair (pair (append [32 32] (dropWhile trimByte? (fst piece))) 173 (snd piece)) rest) pieces) 174 fRows_ self source anchors line group = (lazyList (_ : t) 175 (text rest : let located = fOnLine anchors line in 176 let separators = filter (a : not? (equal? (snd (snd a)) [99])) located in 177 let pieces = fPieces text (fScope separators group) in 178 let indented = (lazyBool (_ : fIndent pieces) (_ : pieces) 179 (not? (emptyList? (filter (a : equal? (snd (snd a)) [99]) located)))) in 180 pair indented (self rest anchors (succ line) 181 (lazyBool (_ : succ group) (_ : group) (emptyList? (dropWhile C.cSpace? text))))) source) 182 fRows source anchors = y fRows_ source anchors 1 0 183 184 fLookup_ self entries key = (lazyList (_ : nothing) 185 (entry rest : lazyBool (_ : just (snd entry)) 186 (_ : self rest key) (equal? (fst entry) key)) entries) 187 fLookup entries key = y fLookup_ entries key 188 fMax a b = lazyBool (_ : a) (_ : b) (lt_? b a) 189 fWidth piece targets column = (let end = add column (length (fst piece)) in 190 lazyMaybe (_ : end) 191 (key : lazyMaybe (_ : succ end) 192 (target : fMax (succ end) target) (fLookup targets key)) (snd piece)) 193 fColumn_ self pieces targets column key = (lazyList (_ : 0) 194 (piece rest : lazyMaybe 195 (_ : self rest targets (fWidth piece targets column) key) 196 (found : lazyBool (_ : succ (add column (length (fst piece)))) 197 (_ : self rest targets (fWidth piece targets column) key) 198 (equal? found key)) (snd piece)) pieces) 199 fColumn pieces targets key = y fColumn_ pieces targets 0 key 200 fTarget rows targets key = foldl fMax 0 (map (row : fColumn row targets key) rows) 201 fKeys rows = foldl (keys row : foldl (seen piece : lazyMaybe 202 (_ : seen) (key : lazyMaybe (_ : append seen [key]) (_ : seen) 203 (fLookup (map (k : pair k t) seen) key)) (snd piece)) keys row) t rows 204 fPut entries key value = (pair (pair key value) 205 (filter (entry : not? (equal? (fst entry) key)) entries)) 206 fPass_ self keys rows targets = (lazyList (_ : targets) 207 (key rest : self rest rows (fPut targets key (fTarget rows targets key))) keys) 208 fPass keys rows targets = y fPass_ keys rows targets 209 -- Later rules may introduce anchors preceding an already-seen anchor. Repeat 210 -- the constraints at most once per key, consuming a finite key list. 211 fTargets_ self remaining keys rows targets = (lazyList (_ : targets) 212 (_ rest : let next = fPass keys rows targets in 213 lazyBool (_ : next) (_ : self rest keys rows next) 214 (equal? next targets)) remaining) 215 fTargets keys rows = y fTargets_ keys keys rows t 216 -- Padding is data-driven by the row fragment, with count consumed only inside 217 -- a runtime continuation (never a known top-level fixed point). 218 fSpaces_ self n = (lazyBool (_ : t) 219 (_ : pair 32 (self (pred_ n))) (isZero_? n)) 220 fSpaces n = y fSpaces_ n 221 fRender_ self pieces targets column = (lazyList (_ : t) 222 (piece rest : let next = fWidth piece targets column in 223 append (fst piece) (append 224 (fSpaces (sub next (add column (length (fst piece))))) 225 (self rest targets next))) pieces) 226 fRender pieces targets = y fRender_ pieces targets 0 227 228 -- Format each definition separately; headers, comments and multiline layout 229 -- remain untouched. Anchors are located in the original source throughout. 230 fApply source anchors = (let rows = fRows (lines source) anchors in 231 let targets = fTargets (fKeys rows) rows in 232 intercalate [10] (map (row : fRender row targets) rows)) 233 -- Definition and blank-line scopes prevent unrelated rules sharing columns. 234 fScope anchors index = map (anchor : pair (fst anchor) 235 (pair index (snd anchor))) anchors 236 fScopes_ self definitions index = (lazyList (_ : t) 237 (anchors rest : append (fScope anchors index) 238 (self rest (succ index))) definitions) 239 fScopes definitions = y fScopes_ definitions 0 240 formatScp source = (P.parserMatchReply 241 (problem rest consumed committed : err problem t) 242 (definitions rest consumed committed : lazyBool 243 (_ : ok source t) 244 (_ : ok (fApply source (fScopes definitions)) t) 245 (emptyList? definitions)) 246 (P.parserWithLexer C.lexScpUnit fDefinitions (fMasked source)))