tricu

lexer.tri (6308B)

---

 !import base *
 !import parser *
 !export *
 
 -- Located character-scanning tools. Input is the canonical character list.
 -- Input characters and position naturals are caller-validated; these are not
 -- text-decoding or arbitrary-tree validation functions. LF alone advances line;
 -- columns/offsets count source characters, not UTF-8 bytes or display cells.
 -- A scan returns a parser reply whose payload is (state, endPosition).
 -- The remainder starts with the first character that failed the predicate.
 lexerPosition line column offset = pair line (pair column offset)
 lexerPositionLine position = fst position
 lexerPositionColumn position = fst (snd position)
 lexerPositionOffset position = snd (snd position)
 lexerStart = lexerPosition 1 1 0
 
 lexerAdvance position character =
   lazyBool
     (_ : lexerPosition (succ (lexerPositionLine position)) 1
            (succ (lexerPositionOffset position)))
     (_ : lexerPosition (lexerPositionLine position)
            (succ (lexerPositionColumn position))
            (succ (lexerPositionOffset position)))
     (equal? character 10)
 
 lexerToken kind payload start end = pair kind (pair payload (pair start end))
 lexerTokenKind token = fst token
 lexerTokenPayload token = fst (snd token)
 lexerTokenStart token = fst (snd (snd token))
 lexerTokenEnd token = snd (snd (snd token))
 
 -- The callbacks and starting position are caller-owned. Capture them once;
 -- stopping leaves the whole first nonmatching suffix and never calls update.
 -- Keep the cheap list eliminator in this hot loop: patterned dispatch measured
 -- worse here. Local recursion still eliminates the explicit-self plumbing.
 lexerScanWhile input position state predicate update = (let rec
   walk remaining end accumulated consumed = (lazyList
     (_ : parserReplyOk (pair accumulated end) remaining consumed false)
     (character rest : lazyBool
       (_ : walk rest (lexerAdvance end character) (update accumulated character) true)
       (_ : parserReplyOk (pair accumulated end) remaining consumed false)
       (predicate character))
     remaining)
   in walk input position state false)
 
 -- Transform the accumulated state without changing the location, remainder,
 -- or consumption flags. Useful for reversing a name after scanning it.
 lexerMapScan transform reply =
   parserMatchReply
     (diagnostic rest consumed committed :
       parserReplyFail diagnostic rest consumed committed)
     (stateAndEnd rest consumed committed :
       parserReplyOk (pair (transform (fst stateAndEnd)) (snd stateAndEnd))
         rest consumed committed)
     reply
 
 -- A successful scan can be used as a trivia skip without inspecting its
 -- accumulator. This destructures only the fixed-format reply; no rescan.
 lexerRemainingAndEnd reply =
   pair (parserReplyRest reply) (snd (parserReplyPayload reply))
 
 -- Ordered, single-character lexical alternatives. Each rule is a pair of
 -- predicate and handler; the first matching handler owns its input and any
 -- failure. This is dispatch, not implicit backtracking over failed scans.
 lexerDispatch rules fallback character = (let rec
   choose remaining = (case remaining of
     [(predicate, handler) | rest] = (lazyBool
       (_ : handler character)
       (_ : choose rest)
       (predicate character))
     _ = fallback character)
   in choose rules)
 
 -- Turn a completed state scan into one located token. `classify state`
 -- supplies (kind, payload); `next` is the enclosing lexer continuation.
 -- Emit/resume are entered after the outer lexer has consumed a prefix; failure
 -- therefore reports consumed=true even when the inner scan consumed nothing.
 lexerEmitScan scan start reversed classify next =
   parserMatchReply
     (diagnostic rest consumed committed :
       parserReplyFail diagnostic rest true committed)
     (stateAndEnd rest consumed committed :
       matchPair
         (kind payload :
           next rest (snd stateAndEnd)
             (pair (lexerToken kind payload start (snd stateAndEnd)) reversed))
         (classify (fst stateAndEnd)))
     scan
 
 -- Consume trivia and resume the outer lexer at its first unconsumed input.
 lexerResumeScan scan next =
   parserMatchReply
     (diagnostic rest consumed committed :
       parserReplyFail diagnostic rest true committed)
     (stateAndEnd rest consumed committed : next rest (snd stateAndEnd))
     scan
 
 -- Scan until a two-character terminator, leaving everything after it intact.
 -- The supplied diagnostic describes EOF before the terminator. This is a
 -- non-nesting primitive; callers that require nesting need an explicit state.
 lexerSkipUntilPair input position first second missing = (let rec
   walk remaining end consumed = (case remaining of
     [] = parserReplyFail missing remaining consumed false
     [character | rest] = (let advanced = lexerAdvance end character in
       lazyBool
         (_ : case rest of
           [next | tail] = (lazyBool
             (_ : parserReplyOk (pair t (lexerAdvance advanced next)) tail true false)
             (_ : walk rest advanced true)
             (equal? next second))
           _ = walk rest advanced true)
         (_ : walk rest advanced true)
         (equal? character first))
     _ = parserReplyFail missing remaining consumed false)
   in walk input position false)
 
 -- Opening delimiter already consumed. Escapes advance by two source cells,
 -- not by the decoded character; invalid escapes retain the escape-led suffix.
 lexerScanQuoted input position close escape decode missing invalid = (let rec
   walk remaining end reversed = (case remaining of
     [] = parserReplyFail missing remaining true false
     [character | rest] = (let advanced = lexerAdvance end character in
       lazyBool
         (_ : parserReplyOk (pair (reverse reversed) advanced) rest true false)
         (_ : lazyBool
           (_ : case rest of
             [escaped | tail] = (lazyMaybe
               (_ : parserReplyFail (invalid escaped advanced) remaining true false)
               (decoded : walk tail (lexerAdvance advanced escaped) (pair decoded reversed))
               (decode escaped))
             _ = parserReplyFail missing remaining true false)
           (_ : walk rest advanced (pair character reversed))
           (equal? character escape))
         (equal? character close))
     _ = parserReplyFail missing remaining true false)
   in walk input position [])