tricu

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

structural.tri (11500B)

      1 !import prelude *
      2 !export *
      3 -- Shared SCP authored IR and independent reference semantics.
      4 
      5 -- Pattern tags: Any, Leaf, Stem, Fork, Capture, Literal, As. Capture slots are unique
      6 -- within a rule; repetition/unification is deliberately not implemented.
      7 patAny = pair 0 t
      8 patLeaf = pair 1 t
      9 patStem child = pair 2 child
     10 patFork left right = pair 3 (pair left right)
     11 patCapture slot = pair 4 slot
     12 patLiteral value = pair 5 value
     13 patAs slot child = pair 6 (pair slot child)
     14 -- Build-time elaboration, NOT an IR tag. A proper list expands into nested
     15 -- Fork/Literal patterns ending in a suffix Capture. Reject an improper list
     16 -- before publishing IR; do not manufacture an invalid pattern as a sentinel.
     17 expandPrefix_ self prefix slot = (triage
     18   (ok (patCapture slot) t)
     19   (_ : err "improper literal prefix" t)
     20   (head rest : bindResult (self rest slot)
     21     (tailPattern _ : ok (patFork (patLiteral head) tailPattern) t))
     22   prefix)
     23 expandPrefix prefix slot = y expandPrefix_ prefix slot
     24 
     25 -- Template tags: Literal (opaque), Capture, Fork, Recur, Call, Stem.
     26 -- Recur continues this consumer; Call invokes a runtime-supplied consumer
     27 -- and binds its result to an explicit return slot for a receiver template.
     28 outLiteral value = pair 0 value
     29 outCapture slot = pair 1 slot
     30 outFork left right = pair 2 (pair left right)
     31 outRecur input state = pair 3 (pair input state)
     32 outCall worker input returnSlot receiver =
     33   pair 4 (pair worker (pair input (pair returnSlot receiver)))
     34 outStem child = pair 5 child
     35 -- Tail delegation to any runtime-supplied consumer with explicit state.
     36 outBecome worker input state = pair 6 (pair worker (pair input state))
     37 -- Intensional structural equality is a general tree operation, not a route helper.
     38 outEqual left right = pair 8 (pair left right)
     39 -- Match a computed tree against ordered, scoped pattern/output arms.
     40 outMatch source arms = pair 9 (pair source arms)
     41 
     42 makeRule inputPattern statePattern output =
     43   pair inputPattern (pair statePattern output)
     44 makeConsumer state rules = pair state rules
     45 
     46 matchPattern_ self pattern value bindings =
     47   matchPair (tag payload :
     48     lazyBool
     49       (_ : just bindings)
     50       (_ : lazyBool
     51         (_ : triage (just bindings) (_ : nothing) (_ _ : nothing) value)
     52         (_ : lazyBool
     53           (_ : triage nothing (child : self payload child bindings)
     54                  (_ _ : nothing) value)
     55           (_ : lazyBool
     56             (_ : matchPair (left right :
     57               triage nothing (_ : nothing)
     58                 (leftValue rightValue :
     59                   lazyMaybe
     60                     (_ : nothing)
     61                     (leftBindings : self right rightValue leftBindings)
     62                     (self left leftValue bindings))
     63                 value) payload)
     64             (_ : lazyBool
     65               (_ : just (pair (pair payload value) bindings))
     66               (_ : lazyBool
     67                 (_ : lazyBool (_ : just bindings) (_ : nothing)
     68                   (equal? payload value))
     69                 (_ : lazyBool
     70                   (_ : matchPair (slot child :
     71                     self child value (pair (pair slot value) bindings)) payload)
     72                   (_ : nothing)
     73                   (equal? tag 6))
     74                 (equal? tag 5))
     75               (equal? tag 4))
     76             (equal? tag 3))
     77           (equal? tag 2))
     78         (equal? tag 1))
     79       (equal? tag 0))
     80     pattern
     81 matchPattern pattern value bindings = y matchPattern_ pattern value bindings
     82 
     83 matchRule rule input state =
     84   matchPair (inputPattern more :
     85     matchPair (statePattern output :
     86       lazyMaybe
     87         (_ : nothing)
     88         (inputBindings :
     89           lazyMaybe
     90             (_ : nothing)
     91             (bindings : just (pair output bindings))
     92             (matchPattern statePattern state inputBindings))
     93         (matchPattern inputPattern input t))
     94       more)
     95     rule
     96 
     97 chooseRule_ self rules input state =
     98   lazyList
     99     (_ : nothing)
    100     (rule rest :
    101       lazyMaybe
    102         (_ : self rest input state)
    103         (selection : just selection)
    104         (matchRule rule input state))
    105     rules
    106 chooseRule rules input state = y chooseRule_ rules input state
    107 
    108 capture_ self bindings slot =
    109   lazyList
    110     (_ : err "unknown capture" t)
    111     (entry rest :
    112       lazyBool
    113         (_ : ok (snd entry) t)
    114         (_ : self rest slot)
    115         (equal? (fst entry) slot))
    116     bindings
    117 capture bindings slot = y capture_ bindings slot
    118 
    119 -- The interpreter's continuation is a tricu value, not a new host action.
    120 -- All recursive template work is under the template's consumed structure.
    121 matchOutputArms_ self output arms value bindings recur invoke = (lazyList
    122   (_ : err "no matching output arm" t)
    123   (arm rest : matchPair (pattern body : lazyMaybe
    124     (_ : self output rest value bindings recur invoke)
    125     (matched : output body matched recur invoke)
    126     (matchPattern pattern value bindings)) arm) arms)
    127 matchOutputArms output arms value bindings recur invoke =
    128   y matchOutputArms_ output arms value bindings recur invoke
    129 
    130 evalOutput_ self output bindings recur invoke initial =
    131   matchPair (tag payload :
    132     lazyBool
    133       (_ : ok payload t)
    134       (_ : lazyBool
    135         (_ : capture bindings payload)
    136         (_ : lazyBool
    137           (_ : matchPair (left right :
    138             bindResult (self left bindings recur invoke initial) (leftValue _ :
    139               bindResult (self right bindings recur invoke initial) (rightValue _ :
    140                 ok (pair leftValue rightValue) t))) payload)
    141           (_ : lazyBool
    142             (_ : matchPair (input state :
    143               bindResult (self input bindings recur invoke initial) (nextInput _ :
    144                 bindResult (self state bindings recur invoke initial) (nextState _ :
    145                   recur nextInput nextState))) payload)
    146             (_ : lazyBool
    147               (_ : matchPair (worker more :
    148                 matchPair (input continuation :
    149                   matchPair (returnSlot receiver :
    150                     bindResult (self worker bindings recur invoke initial) (workerValue _ :
    151                       bindResult (self input bindings recur invoke initial) (argument _ :
    152                         bindResult (invoke workerValue argument (initial workerValue)) (returned _ :
    153                           self receiver
    154                             (pair (pair returnSlot returned) bindings)
    155                             recur invoke initial))))
    156                     continuation) more) payload)
    157               (_ : lazyBool
    158                 (_ : bindResult (self payload bindings recur invoke initial)
    159                   (child _ : ok (t child) t))
    160                 (_ : lazyBool
    161                   (_ : matchPair (worker more : matchPair (input state :
    162                     bindResult (self worker bindings recur invoke initial) (target _ :
    163                       bindResult (self input bindings recur invoke initial) (argument _ :
    164                         bindResult (self state bindings recur invoke initial) (newState _ :
    165                           invoke target argument newState)))) more) payload)
    166                   (_ : lazyBool
    167                     (_ : matchPair (left right :
    168                       bindResult (self left bindings recur invoke initial) (a _ :
    169                         bindResult (self right bindings recur invoke initial) (b _ :
    170                           ok (equal? a b) t))) payload)
    171                     (_ : lazyBool
    172                       (_ : matchPair (source arms :
    173                         bindResult (self source bindings recur invoke initial)
    174                           (value _ : matchOutputArms
    175                             (child bound recurrence invocation :
    176                               self child bound recurrence invocation initial)
    177                             arms value bindings recur invoke)) payload)
    178                       (_ : err "unknown output form" t)
    179                       (equal? tag 9))
    180                     (equal? tag 8))
    181                   (equal? tag 6))
    182                 (equal? tag 5))
    183               (equal? tag 4))
    184             (equal? tag 3))
    185           (equal? tag 2))
    186         (equal? tag 1))
    187       (equal? tag 0))
    188     output
    189 evalOutputUsing output bindings recur invoke initial =
    190   y evalOutput_ output bindings recur invoke initial
    191 evalOutput output bindings recur invoke =
    192   evalOutputUsing output bindings recur invoke fst
    193 
    194 runConsumer_ self input consumer state =
    195   lazyMaybe
    196     (_ : err "no matching consumer rule" t)
    197     (selection :
    198       matchPair (output bindings :
    199         evalOutput output bindings
    200           (nextInput nextState : self nextInput consumer nextState)
    201           (worker argument initial : self argument worker initial))
    202         selection)
    203     (chooseRule (snd consumer) input state)
    204 runConsumer consumer input = y runConsumer_ input consumer (fst consumer)
    205 
    206 -- Transform only designated output literals. Never descend into their
    207 -- arbitrary payloads, captured input values, or structural patterns.
    208 replaceOutputLiteral_ self output old replacement =
    209   matchPair (tag payload :
    210     lazyBool
    211       (_ : outLiteral (lazyBool (_ : replacement) (_ : payload)
    212                             (equal? payload old)))
    213       (_ : lazyBool
    214         (_ : output)
    215         (_ : lazyBool
    216           (_ : matchPair (left right :
    217             outFork (self left old replacement) (self right old replacement))
    218             payload)
    219           (_ : lazyBool
    220             (_ : matchPair (input state :
    221               outRecur (self input old replacement) (self state old replacement))
    222               payload)
    223             (_ : lazyBool
    224               (_ : matchPair (worker more :
    225                 matchPair (input continuation :
    226                   matchPair (returnSlot receiver :
    227                     outCall (self worker old replacement)
    228                       (self input old replacement) returnSlot
    229                       (self receiver old replacement)) continuation)
    230                 more) payload)
    231               (_ : lazyBool
    232                 (_ : outStem (self payload old replacement))
    233                 (_ : lazyBool
    234                   (_ : matchPair (worker more : matchPair (input state :
    235                     outBecome (self worker old replacement)
    236                       (self input old replacement)
    237                       (self state old replacement)) more) payload)
    238                   (_ : lazyBool
    239                     (_ : matchPair (left right :
    240                       outEqual (self left old replacement)
    241                         (self right old replacement)) payload)
    242                     (_ : lazyBool
    243                       (_ : matchPair (source arms :
    244                         outMatch (self source old replacement)
    245                           (map (arm : matchPair (pattern body :
    246                             pair pattern (self body old replacement)) arm)
    247                             arms)) payload)
    248                       (_ : output)
    249                       (equal? tag 9))
    250                     (equal? tag 8))
    251                   (equal? tag 6))
    252                 (equal? tag 5))
    253               (equal? tag 4))
    254             (equal? tag 3))
    255           (equal? tag 2))
    256         (equal? tag 1))
    257       (equal? tag 0))
    258     output
    259 replaceOutputLiteral output old replacement =
    260   y replaceOutputLiteral_ output old replacement
    261 
    262 replaceRuleLiteral rule old replacement =
    263   matchPair (inputPattern more :
    264     matchPair (statePattern output :
    265       makeRule inputPattern statePattern
    266         (replaceOutputLiteral output old replacement)) more) rule
    267 replaceLiteral consumer old replacement =
    268   makeConsumer (fst consumer) (map (rule : replaceRuleLiteral rule old replacement) (snd consumer))