tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

0740adbe2a2c04e682113e661c24f4e39a29b2af22255d27dc5650b05f096acc.tri (6595B)

      1 !import prelude *
      2 !import parser *
      3 !export *
      4 
      5 -- Located character-scanning tools. Input is the canonical character list.
      6 -- A scan returns a parser reply whose payload is (state, endPosition).
      7 -- The remainder starts with the first character that failed the predicate.
      8 lexerPosition line column offset = pair line (pair column offset)
      9 lexerPositionLine position = fst position
     10 lexerPositionColumn position = fst (snd position)
     11 lexerPositionOffset position = snd (snd position)
     12 lexerStart = lexerPosition 1 1 0
     13 
     14 lexerAdvance position character =
     15   lazyBool
     16     (_ : lexerPosition (succ (lexerPositionLine position)) 1
     17            (succ (lexerPositionOffset position)))
     18     (_ : lexerPosition (lexerPositionLine position)
     19            (succ (lexerPositionColumn position))
     20            (succ (lexerPositionOffset position)))
     21     (equal? character 10)
     22 
     23 lexerToken kind payload start end = pair kind (pair payload (pair start end))
     24 lexerTokenKind token = fst token
     25 lexerTokenPayload token = fst (snd token)
     26 lexerTokenStart token = fst (snd (snd token))
     27 lexerTokenEnd token = snd (snd (snd token))
     28 
     29 -- The consumed input is the first recursive argument. The accumulator and
     30 -- predicate cannot cause an abstract source stream to unfold on import.
     31 lexerScanWhile_ self input position state predicate update consumed =
     32   lazyList
     33     (_ : parserReplyOk (pair state position) input consumed false)
     34     (character rest :
     35       lazyBool
     36         (_ : self rest (lexerAdvance position character)
     37                (update state character) predicate update true)
     38         (_ : parserReplyOk (pair state position) input consumed false)
     39         (predicate character))
     40     input
     41 
     42 lexerScanWhile = (input position state predicate update :
     43   y lexerScanWhile_ input position state predicate update false)
     44 
     45 -- Transform the accumulated state without changing the location, remainder,
     46 -- or consumption flags. Useful for reversing a name after scanning it.
     47 lexerMapScan transform reply =
     48   parserMatchReply
     49     (diagnostic rest consumed committed :
     50       parserReplyFail diagnostic rest consumed committed)
     51     (stateAndEnd rest consumed committed :
     52       parserReplyOk (pair (transform (fst stateAndEnd)) (snd stateAndEnd))
     53         rest consumed committed)
     54     reply
     55 
     56 -- A successful scan can be used as a trivia skip without inspecting its
     57 -- accumulator. This destructures only the fixed-format reply; no rescan.
     58 lexerRemainingAndEnd reply =
     59   pair (parserReplyRest reply) (snd (parserReplyPayload reply))
     60 
     61 -- Ordered, single-character lexical alternatives. Each rule is a pair of
     62 -- predicate and handler; the first matching handler owns its input and any
     63 -- failure. This is dispatch, not implicit backtracking over failed scans.
     64 lexerDispatch_ self rules character fallback =
     65   lazyList
     66     (_ : fallback character)
     67     (rule rest :
     68       lazyBool
     69         (_ : snd rule character)
     70         (_ : self rest character fallback)
     71         (fst rule character))
     72     rules
     73 
     74 lexerDispatch = (rules fallback character :
     75   y lexerDispatch_ rules character fallback)
     76 
     77 -- Turn a completed state scan into one located token. `classify state`
     78 -- supplies (kind, payload); `next` is the enclosing lexer continuation.
     79 lexerEmitScan scan start reversed classify next =
     80   parserMatchReply
     81     (diagnostic rest consumed committed :
     82       parserReplyFail diagnostic rest true committed)
     83     (stateAndEnd rest consumed committed :
     84       matchPair
     85         (kind payload :
     86           next rest (snd stateAndEnd)
     87             (pair (lexerToken kind payload start (snd stateAndEnd)) reversed))
     88         (classify (fst stateAndEnd)))
     89     scan
     90 
     91 -- Consume trivia and resume the outer lexer at its first unconsumed input.
     92 lexerResumeScan scan next =
     93   parserMatchReply
     94     (diagnostic rest consumed committed :
     95       parserReplyFail diagnostic rest true committed)
     96     (stateAndEnd rest consumed committed : next rest (snd stateAndEnd))
     97     scan
     98 
     99 -- Scan until a two-character terminator, leaving everything after it intact.
    100 -- The supplied diagnostic describes EOF before the terminator. This is a
    101 -- non-nesting primitive; callers that require nesting need an explicit state.
    102 lexerSkipUntilPair_ self input position first second missing consumed =
    103   lazyList
    104     (_ : parserReplyFail missing input consumed false)
    105     (character rest :
    106       lazyBool
    107         (_ : lazyList
    108           (_ : self rest (lexerAdvance position character)
    109                  first second missing true)
    110           (next tail :
    111             lazyBool
    112               (_ : parserReplyOk
    113                 (pair t (lexerAdvance (lexerAdvance position character) next))
    114                 tail true false)
    115               (_ : self rest (lexerAdvance position character)
    116                      first second missing true)
    117               (equal? next second))
    118           rest)
    119         (_ : self rest (lexerAdvance position character)
    120                first second missing true)
    121         (equal? character first))
    122     input
    123 
    124 lexerSkipUntilPair = (input position first second missing :
    125   y lexerSkipUntilPair_ input position first second missing false)
    126 
    127 -- Quoted strings use a caller-supplied escape decoder (character -> Maybe
    128 -- decodedCharacter). Both diagnostics are values, not host exceptions.
    129 -- `position` is immediately after an already-consumed opening delimiter.
    130 lexerQuotedEscape self input rest position reversed close escape decode missing invalid =
    131   lazyList
    132     (_ : parserReplyFail missing input true false)
    133     (character remaining :
    134       lazyMaybe
    135         (_ : parserReplyFail
    136           (invalid character (lexerAdvance position escape)) input true false)
    137         (decoded : self remaining
    138           (lexerAdvance (lexerAdvance position escape) character)
    139           (pair decoded reversed) close escape decode missing invalid)
    140         (decode character))
    141     rest
    142 
    143 lexerScanQuoted_ self input position reversed close escape decode missing invalid =
    144   lazyList
    145     (_ : parserReplyFail missing input true false)
    146     (character rest :
    147       lazyBool
    148         (_ : parserReplyOk
    149           (pair (reverse reversed) (lexerAdvance position character))
    150           rest true false)
    151         (_ : lazyBool
    152           (_ : lexerQuotedEscape self input rest position reversed
    153                close escape decode missing invalid)
    154           (_ : self rest (lexerAdvance position character)
    155                (pair character reversed) close escape decode missing invalid)
    156           (equal? character escape))
    157         (equal? character close))
    158     input
    159 
    160 lexerScanQuoted = (input position close escape decode missing invalid :
    161   y lexerScanQuoted_ input position t close escape decode missing invalid)
    162