equations.tri (16645B)
1 !import prelude * 2 !import parser * 3 !import source_lexer * 4 !import source_ast * 5 !import source_pattern * 6 !import source_core * 7 !export * 8 9 -- Located surface patterns have one AST kind and explicit lowerer tags 0..7. 10 -- Do not derive tags by arithmetic on an abstract AST kind at export time. 11 -- Pin payloads are located names, not resolved core yet. 12 sourceEquationPattern tag payload start end = sourceAstNode sourceAstPatternKind (pair tag payload) start end 13 sourceEquationTag pattern = fst (sourceAstPayload pattern) 14 sourceEquationPayload pattern = snd (sourceAstPayload pattern) 15 sourceEquationLocation pattern = sourceAstStart pattern 16 sourceEquationExpect kind input{[token | rest]} = (lazyBool 17 (_ : parserReplyOk token rest true false) 18 (_ : parserReplyFail (parserDiagnostic 2 kind (sourceTokenKind token) 19 (sourceTokenStart token) t) input false false) 20 (equal? (sourceTokenKind token) kind)) 21 sourceEquationExpect kind input = 22 parserReplyFail (parserDiagnostic 2 kind t t t) input false false 23 sourceEquationSkip = parserMap (_ : t) (parserMany (sourceEquationExpect sourceTokenNewline)) 24 sourceEquationError label input{[token | _]} = 25 parserReplyFail (parserDiagnostic 48 label (sourceTokenKind token) 26 (sourceTokenStart token) t) input false false 27 sourceEquationError label input = 28 parserReplyFail (parserDiagnostic 48 label t t t) input false false 29 sourceEquationFromToken tag token = (sourceEquationPattern tag (sourceTokenPayload token) 30 (sourceTokenStart token) (sourceTokenEnd token)) 31 sourceEquationWildcard token = sourceEquationPattern 0 t (sourceTokenStart token) (sourceTokenEnd token) 32 sourceEquationLeaf token = sourceEquationPattern 1 t (sourceTokenStart token) (sourceTokenEnd token) 33 sourceEquationLiteral token = sourceEquationFromToken 5 token 34 sourceEquationPair left right = (sourceEquationPattern 3 (pair left right) 35 (sourceAstStart left) (sourceAstEnd right)) 36 sourceEquationNil token = sourceEquationLeaf token 37 sourceEquationList [head | rest] nil = 38 sourceEquationPair head (sourceEquationList rest nil) 39 sourceEquationList _ nil = nil 40 41 sourceEquationName parse input = (parserBind (sourceEquationExpect sourceTokenName) (name : 42 lazyBool (_ : parserPure (sourceEquationWildcard name)) 43 (_ : parserBind (parserOptional (sourceEquationExpect sourceTokenLeftBrace)) (brace : 44 lazyMaybe (_ : parserPure (sourceEquationFromToken 4 name)) 45 (open : parserThen sourceEquationSkip 46 (parserBind (sourceEquationInside parse) (child : 47 parserThen sourceEquationSkip 48 (parserMap (close : sourceEquationPattern 6 49 (pair (sourceTokenPayload name) child) 50 (sourceTokenStart name) (sourceTokenEnd close)) 51 (sourceEquationExpect sourceTokenRightBrace))))) brace)) 52 (equal? (sourceTokenPayload name) "_")) input) 53 sourceEquationPin input = (parserBind (sourceEquationExpect sourceTokenPin) (pin : 54 parserMap (name : sourceEquationPattern 7 (sourceAstName name) 55 (sourceTokenStart pin) (sourceTokenEnd name)) 56 (sourceEquationExpect sourceTokenName)) input) 57 58 -- Braces and parentheses contain one complete pattern. A leading `t` may 59 -- have zero, one or two child atoms here, never in an ungrouped argument. 60 sourceEquationConstructor parse input = (parserBind (sourceEquationExpect sourceTokenT) (leaf : 61 parserThen sourceEquationSkip 62 (parserBind (parserMany (parserBefore parse sourceEquationSkip)) (children : 63 lazyList (_ : parserPure (sourceEquationLeaf leaf)) 64 (first rest : lazyList 65 (_ : parserPure (sourceEquationPattern 2 first 66 (sourceTokenStart leaf) (sourceAstEnd first))) 67 (second tail : lazyList 68 (_ : parserPure (sourceEquationPattern 3 (pair first second) 69 (sourceTokenStart leaf) (sourceAstEnd second))) 70 (extra unused : tokens : sourceEquationError "at most two tree children" tokens) 71 tail) rest) children))) input) 72 sourceEquationInside parse input = (parserBind 73 (parserBefore (parserOr (sourceEquationConstructor parse) parse) sourceEquationSkip) (left : 74 parserBind (parserOptional (sourceEquationExpect sourceTokenComma)) (comma : 75 lazyMaybe (_ : parserPure left) 76 (_ : parserThen sourceEquationSkip 77 (parserMap (right : sourceEquationPair left right) parse)) comma)) input) 78 sourceEquationGroup parse input = (parserBind (sourceEquationExpect sourceTokenOpen) (open : 79 parserThen sourceEquationSkip 80 (parserBind (sourceEquationInside parse) (child : 81 parserThen sourceEquationSkip 82 (parserMap (close : sourceAstNode (sourceAstKind child) (sourceAstPayload child) 83 (sourceTokenStart open) (sourceTokenEnd close)) 84 (sourceEquationExpect sourceTokenClose))))) input) 85 sourceEquationListSpan open close elements tail = (let node = sourceEquationList elements tail in 86 sourceAstNode (sourceAstKind node) (sourceAstPayload node) 87 (sourceTokenStart open) (sourceTokenEnd close)) 88 sourceEquationListPattern parse input = (parserBind (sourceEquationExpect sourceTokenLeftBracket) (open : 89 parserThen sourceEquationSkip 90 (parserBind (parserMany (parserBefore parse sourceEquationSkip)) (elements : 91 parserBind (parserOptional (parserThen (sourceEquationExpect sourceTokenBar) 92 (parserThen sourceEquationSkip (parserBefore parse sourceEquationSkip)))) (tail : 93 parserBind (sourceEquationExpect sourceTokenRightBracket) (close : 94 lazyMaybe 95 (_ : parserPure (sourceEquationListSpan open close elements (sourceEquationNil close))) 96 (rest : lazyList 97 (_ : tokens : sourceEquationError "nonempty list prefix" tokens) 98 (head unused : parserPure (sourceEquationListSpan open close elements rest)) elements) 99 tail))))) input) 100 -- Each recognized prefix consumes its opening token. Choosing once preserves 101 -- consumed failures; an unknown prefix keeps the ordinary unconsumed error. 102 sourceEquationParse input = (lazyList 103 (_ : sourceEquationError "pattern" input) 104 (token _ : (let parse = (case sourceTokenKind token of 105 ^sourceTokenName = sourceEquationName sourceEquationParse 106 ^sourceTokenT = parserMap sourceEquationLeaf (sourceEquationExpect sourceTokenT) 107 ^sourceTokenNumber = parserMap sourceEquationLiteral (sourceEquationExpect sourceTokenNumber) 108 ^sourceTokenString = parserMap sourceEquationLiteral (sourceEquationExpect sourceTokenString) 109 ^sourceTokenPin = sourceEquationPin 110 ^sourceTokenOpen = sourceEquationGroup sourceEquationParse 111 ^sourceTokenLeftBracket = sourceEquationListPattern sourceEquationParse 112 _ = sourceEquationError "pattern") 113 in parse input)) input) 114 115 -- Binding heads are shared by program and local parsers. Zero-argument 116 -- values remain ordinary expressions; positive-arity bindings retain equations. 117 sourceEquationBinding valueParser input = (parserBind 118 (sourceEquationExpect sourceTokenName) (name : 119 parserBind (parserMany sourceEquationParse) (patterns : 120 parserThen (sourceEquationExpect sourceTokenAssign) 121 (parserMap (body : pair name (lazyList (_ : body) 122 (_ rest : sourceAstEquations [(pair patterns body)] 123 (sourceTokenStart name) (sourceAstEnd body)) patterns)) valueParser))) input) 124 125 -- Merge only contiguous positive-arity plain equations. Values/annotations 126 -- stay ordinary nodes and cannot silently become multi-equation definitions. 127 sourceEquationMerge prior next = (pair (fst prior) 128 (sourceAstEquations (pair (fst (sourceAstPayload (snd next))) (sourceAstPayload (snd prior))) 129 (sourceAstStart (snd prior)) (sourceAstEnd (snd next)))) 130 -- A singleton, unique, all-name head needs no matcher. Keep this cheap path 131 -- for ordinary compiler/library functions and their original binder spans. 132 sourceEquationPlain? patterns = (let rec 133 walk patterns seen = (lazyList (_ : true) 134 (pattern rest : lazyBool 135 (_ : lazyBool (_ : false) 136 (_ : walk rest (pair (sourceEquationPayload pattern) seen)) 137 (sourceEquationHasName seen (sourceEquationPayload pattern))) 138 (_ : false) (equal? (sourceEquationTag pattern) 4)) patterns) 139 in walk patterns t) 140 sourceEquationLambda body pattern = (sourceAstLambda 141 (sourceToken sourceTokenName (sourceEquationPayload pattern) 142 (sourceAstStart pattern) (sourceAstEnd pattern)) body) 143 sourceEquationFinishValue node equations = (lazyList (_ : node) 144 (equation rest : lazyBool 145 (_ : foldr sourceEquationLambda (snd equation) (fst equation)) 146 (_ : sourceAstEquations equations (sourceAstStart node) (sourceAstEnd node)) 147 (and? (emptyList? rest) (sourceEquationPlain? (fst equation)))) equations) 148 sourceEquationFinish binding = (lazyBool 149 (_ : pair (fst binding) (sourceEquationFinishValue (snd binding) 150 (reverse (sourceAstPayload (snd binding))))) 151 (_ : binding) (equal? (sourceAstKind (snd binding)) sourceAstEquationsKind)) 152 sourceEquationGroups bindings = (let rec 153 walk bindings reversed = (lazyList 154 (_ : ok (map sourceEquationFinish (reverse reversed)) t) 155 (binding rest : lazyList 156 (_ : walk rest [binding]) 157 (prior tail : lazyBool 158 (_ : lazyBool 159 (_ : walk rest (pair (sourceEquationMerge prior binding) tail)) 160 (_ : walk rest (pair binding reversed)) 161 (and? (equal? (sourceAstKind (snd prior)) sourceAstEquationsKind) 162 (equal? (sourceAstKind (snd binding)) sourceAstEquationsKind))) 163 (_ : walk rest (pair binding reversed)) 164 (equal? (sourceTokenPayload (fst binding)) (sourceTokenPayload (fst prior)))) reversed) 165 bindings) 166 in walk bindings t) 167 168 -- Traversals consume surface pattern syntax before inspecting control state. 169 sourceEquationCaptures pattern = (let tag = sourceEquationTag pattern in 170 let payload = sourceEquationPayload pattern in 171 lazyBool (_ : [payload]) 172 (_ : lazyBool (_ : pair (fst payload) (sourceEquationCaptures (snd payload))) 173 (_ : lazyBool (_ : sourceEquationCaptures payload) 174 (_ : lazyBool (_ : append (sourceEquationCaptures (fst payload)) (sourceEquationCaptures (snd payload))) 175 (_ : t) (equal? tag 3)) (equal? tag 2)) (equal? tag 6)) (equal? tag 4)) 176 sourceEquationPins pattern = (let tag = sourceEquationTag pattern in 177 let payload = sourceEquationPayload pattern in 178 lazyBool (_ : [payload]) 179 (_ : lazyBool (_ : sourceEquationPins (snd payload)) 180 (_ : lazyBool (_ : sourceEquationPins payload) 181 (_ : lazyBool (_ : append (sourceEquationPins (fst payload)) (sourceEquationPins (snd payload))) 182 (_ : t) (equal? tag 3)) (equal? tag 2)) (equal? tag 6)) (equal? tag 7)) 183 sourceEquationCollect patterns collect = concatMap collect patterns 184 185 -- Look ahead across this head, allowing newlines inside delimiters. Nested 186 -- let/do assignments belong to expressions, not definitions. The delimiter 187 -- stack comes from consumed tokens, never an arithmetic depth counter. 188 sourceEquationHeadStop? kind = (or? (equal? kind sourceTokenCase) (or? (equal? kind sourceTokenLet) 189 (or? (equal? kind sourceTokenIn) (or? (equal? kind sourceTokenWhere) 190 (or? (equal? kind sourceTokenDo) (or? (equal? kind sourceTokenBindArrow) 191 (or? (equal? kind sourceTokenPipeBackward) (equal? kind sourceTokenPipeForward)))))))) 192 sourceEquationOpening kind = (lazyBool (_ : just sourceTokenClose) 193 (_ : lazyBool (_ : just sourceTokenRightBracket) 194 (_ : lazyBool (_ : just sourceTokenRightBrace) (_ : nothing) 195 (equal? kind sourceTokenLeftBrace)) (equal? kind sourceTokenLeftBracket)) 196 (equal? kind sourceTokenOpen)) 197 sourceEquationAssignLine? input = (let rec 198 walk input delimiters = (lazyList (_ : false) 199 (token rest : let kind = sourceTokenKind token in (lazyBool (_ : true) 200 (_ : lazyBool (_ : false) 201 (_ : lazyBool 202 (_ : lazyBool (_ : false) (_ : walk rest delimiters) (emptyList? delimiters)) 203 (_ : lazyMaybe 204 (_ : lazyList (_ : walk rest delimiters) 205 (close tail : lazyBool (_ : walk rest tail) 206 (_ : walk rest delimiters) (equal? kind close)) delimiters) 207 (close : walk rest (pair close delimiters)) (sourceEquationOpening kind)) 208 (equal? kind sourceTokenNewline)) (sourceEquationHeadStop? kind)) 209 (equal? kind sourceTokenAssign))) input) 210 in walk input t) 211 sourceEquationBindingHead? input = (lazyList (_ : false) 212 (token rest : and? (equal? (sourceTokenKind token) sourceTokenName) 213 (sourceEquationAssignLine? rest)) input) 214 sourceEquationHasName names name = lExist? name names 215 sourceEquationUnique bindings = (let rec 216 walk bindings seen = (lazyList (_ : ok t t) 217 (binding rest : let name = sourceTokenPayload (fst binding) in (lazyBool 218 (_ : err (parserDiagnostic 30 name name (sourceTokenStart (fst binding)) t) binding) 219 (_ : walk rest (pair name seen)) (sourceEquationHasName seen name))) bindings) 220 in walk bindings t) 221 222 -- Syntax-only validation happens before dependency/name checking. In 223 -- particular a confusing capture/pin collision must not become a missing-name 224 -- or accidental dependency-cycle error. Pins in this skeleton are never run. 225 sourceEquationSkeleton pattern = (let tag = sourceEquationTag pattern in 226 let payload = sourceEquationPayload pattern in 227 sourcePatternNode tag 228 (lazyBool (_ : sourceEquationSkeleton payload) 229 (_ : lazyBool (_ : pair (sourceEquationSkeleton (fst payload)) (sourceEquationSkeleton (snd payload))) 230 (_ : lazyBool (_ : pair (fst payload) (sourceEquationSkeleton (snd payload))) 231 (_ : lazyBool (_ : spLit t) (_ : payload) (equal? tag 7)) 232 (equal? tag 6)) (equal? tag 3)) (equal? tag 2)) 233 (sourceAstStart pattern)) 234 sourceEquationSkeletonArm equation = (sourceEquation 235 (map sourceEquationSkeleton (fst equation)) 236 (sourceCoreLeaf (sourceAstStart (snd equation)) (sourceAstEnd (snd equation)))) 237 sourceEquationCheckPins patterns = (let 238 captures = sourceEquationCollect patterns sourceEquationCaptures 239 in let rec walk pins = (lazyList (_ : ok t t) 240 (pin rest : lazyBool 241 (_ : err (parserDiagnostic 48 "pin outside equation captures" 242 (sourceAstPayload pin) (sourceAstStart pin) t) pin) 243 (_ : walk rest) (sourceEquationHasName captures (sourceAstPayload pin))) pins) 244 in walk (sourceEquationCollect patterns sourceEquationPins)) 245 sourceEquationCheckArms equations = (lazyList (_ : ok t t) 246 (equation rest : bindResult (sourceEquationCheckPins (fst equation)) 247 (_ _ : sourceEquationCheckArms rest)) equations) 248 sourceEquationValidateArms equations = (lazyList 249 (_ : err (parserDiagnostic 48 "nonempty equations" t t t) t) 250 (first rest : spValidateEquations (map sourceEquationSkeletonArm equations) 251 (length (fst first))) equations) 252 sourceEquationCheckGroup node = (lazyResult 253 (diagnostic remainder : err diagnostic remainder) 254 (_ unused : sourceEquationCheckArms (sourceAstPayload node)) 255 (sourceEquationValidateArms (sourceAstPayload node))) 256 sourceEquationOrdinaryChildren node = (let payload = sourceAstPayload node in 257 case sourceAstKind node of 258 ^sourceAstApplyKind = [(fst payload) (snd payload)] 259 ^sourceAstLambdaKind = [(snd payload)] 260 ^sourceAstGroupKind = [payload] 261 ^sourceAstListKind = payload 262 ^sourceAstLetKind = [(sourceAstLetValue node) (sourceAstLetBody node)] 263 ^sourceAstPipeKind = [(sourceAstPipeLeft node) (sourceAstPipeRight node)] 264 ^sourceAstDoKind = [(sourceAstDoLower node)] 265 ^sourceAstEquationsKind = map snd payload 266 _ = t) 267 sourceEquationVisit nodes visit = (lazyList (_ : ok t t) 268 (node rest : lazyResult (diagnostic remainder : err diagnostic remainder) 269 (_ unused : sourceEquationVisit rest visit) (visit node)) nodes) 270 sourceEquationValidate node = (lazyResult 271 (diagnostic remainder : err diagnostic remainder) 272 (_ unused : sourceEquationVisit (sourceEquationChildren node) sourceEquationValidate) 273 (sourceEquationCheckNode node)) 274 275 276 sourceEquationChildren node = (let 277 children ^sourceAstCaseKind = [(sourceAstCaseSubject node) (sourceAstCaseMatcher node)] 278 children ^sourceAstRecKind = [(sourceAstLetValue node) (sourceAstLetBody node)] 279 children _ = sourceEquationOrdinaryChildren node 280 in children (sourceAstKind node)) 281 282 -- Reject explicit recursive values before free-name analysis, even if unused. 283 sourceEquationCheckNode node = (let 284 check ^sourceAstEquationsKind = sourceEquationCheckGroup node 285 check ^sourceAstRecKind = (lazyBool (_ : ok t t) 286 (_ : err (parserDiagnostic 48 "recursive function requires parameters" 287 (sourceAstLetName node) (sourceTokenStart (fst (sourceAstPayload node))) t) node) 288 (sourceAstFunction? (sourceAstLetValue node))) 289 check _ = ok t t 290 in check (sourceAstKind node))