tricu

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

e31cd89fb71fb7606a05a9bd0afd553f764b40bc0731d944aea1d63e5643c5b9.tri (11888B)

      1 !import prelude *
      2 !import parser *
      3 !import source_parser *
      4 !import source_ast *
      5 !import source_lexer *
      6 !import source_core *
      7 !import source_equations *
      8 !import source_pattern *
      9 !export *
     10 
     11 -- Innermost binder wins, with de Bruijn index zero. Lookup stops at the
     12 -- first match without inspecting the remaining entries or external values.
     13 sourceFindBinder binders name = (let rec
     14   find binders index = (lazyList (_ : nothing)
     15     (binder rest : lazyBool (_ : just index)
     16       (_ : find rest (succ index)) (equal? binder name)) binders)
     17   in find binders 0)
     18 
     19 -- CompileEnvironment is a list of (qualifiedName, already-resolved Tree).
     20 sourceFindExternal entries name = (let rec
     21   find entries = (lazyList (_ : nothing)
     22     (entry rest : lazyBool (_ : just (snd entry))
     23       (_ : find rest) (equal? (fst entry) name)) entries)
     24   in find entries)
     25 
     26 sourceResolveName node binders environment =
     27   lazyMaybe
     28     (_ : lazyMaybe
     29       (_ : err
     30         (parserDiagnostic 20 (sourceAstPayload node) t
     31           (sourceAstStart node) t)
     32         node)
     33       (tree : ok (sourceCoreExternal tree
     34                     (sourceAstStart node) (sourceAstEnd node)) t)
     35       (sourceFindExternal environment (sourceAstPayload node)))
     36     (index : ok (sourceCoreBound index
     37                   (sourceAstStart node) (sourceAstEnd node)) t)
     38     (sourceFindBinder binders (sourceAstPayload node))
     39 
     40 sourceResolveApply resolve node binders environment =
     41   lazyResult
     42     (diagnostic rest : err diagnostic rest)
     43     (left unused :
     44       lazyResult
     45         (diagnostic rest : err diagnostic rest)
     46         (right unused :
     47           ok (sourceCoreApply left right
     48                 (sourceAstStart node) (sourceAstEnd node)) t)
     49         (resolve (snd (sourceAstPayload node)) binders environment))
     50     (resolve (fst (sourceAstPayload node)) binders environment)
     51 
     52 sourceResolvePipe resolve node binders environment =
     53   lazyResult
     54     (diagnostic remainder : err diagnostic remainder)
     55     (left unused :
     56       lazyResult
     57         (diagnostic remainder : err diagnostic remainder)
     58         (right unused :
     59           lazyBool
     60             (_ : ok (sourceCoreApply left right
     61                   (sourceAstStart node) (sourceAstEnd node)) t)
     62             (_ : ok (sourceCoreApply right left
     63                   (sourceAstStart node) (sourceAstEnd node)) t)
     64             (equal? (sourceAstPipeDirection node)
     65               sourceTokenPipeBackward))
     66         (resolve (sourceAstPipeRight node) binders environment))
     67     (resolve (sourceAstPipeLeft node) binders environment)
     68 
     69 sourceResolveLambda resolve node binders environment =
     70   lazyResult
     71     (diagnostic rest : err diagnostic rest)
     72     (body unused :
     73       ok (sourceCoreLambda body
     74             (sourceAstStart node) (sourceAstEnd node)) t)
     75     (resolve (snd (sourceAstPayload node))
     76       (pair (fst (sourceAstPayload node)) binders) environment)
     77 
     78 sourceResolveGroup resolve node binders environment =
     79   lazyResult
     80     (diagnostic rest : err diagnostic rest)
     81     (body unused :
     82       ok (sourceCoreWithSpan body
     83             (sourceAstStart node) (sourceAstEnd node)) t)
     84     (resolve (sourceAstPayload node) binders environment)
     85 
     86 -- Resolve the value outside the new binder, and the body inside it. The
     87 -- core representation needs no special let node: (name : body) value.
     88 sourceResolveDo resolve node binders environment =
     89   lazyResult
     90     (diagnostic remainder : err diagnostic remainder)
     91     (core remainder : ok
     92       (sourceCoreWithSpan core (sourceAstStart node) (sourceAstEnd node)) t)
     93     (resolve (sourceAstDoLower node) binders environment)
     94 
     95 sourceResolveLocal resolve node binders environment =
     96   lazyResult
     97     (diagnostic remainder : err diagnostic remainder)
     98     (value unused :
     99       lazyResult
    100         (diagnostic remainder : err diagnostic remainder)
    101         (body unused : ok
    102           (sourceCoreApply
    103             (sourceCoreLambda body (sourceAstStart node) (sourceAstEnd node))
    104             value (sourceAstStart node) (sourceAstEnd node)) t)
    105         (resolve (sourceAstLetBody node)
    106           (pair (sourceAstLetName node) binders) environment))
    107     (resolve (sourceAstLetValue node) binders environment)
    108 
    109 -- Resolve children in source order so the first missing name keeps its own
    110 -- location. Accumulate in reverse with constant-time cons, then reverse once.
    111 sourceResolveElements nodes resolve binders environment = (let rec
    112   collect nodes reversed = (lazyList
    113     (_ : ok (reverse reversed) t)
    114     (element rest : lazyResult
    115       (diagnostic remainder : err diagnostic remainder)
    116       (core unused : collect rest (pair core reversed))
    117       (resolve element binders environment)) nodes)
    118   in collect nodes t)
    119 
    120 sourceResolveList resolve node binders environment =
    121   lazyResult
    122     (diagnostic remainder : err diagnostic remainder)
    123     (elements remainder : ok
    124       (sourceCoreList elements (sourceAstStart node) (sourceAstEnd node)) t)
    125     (sourceResolveElements (sourceAstPayload node) resolve binders environment)
    126 
    127 -- Pins resolve against surrounding binders only; equation captures are
    128 -- introduced together for the body, in the lowerer's reverse lexical order.
    129 sourceResolvePatternNode pattern payload = (sourcePatternNode
    130   (sourceEquationTag pattern) payload (sourceAstStart pattern))
    131 sourceResolvePatternChild resolve pattern child binders environment = (lazyResult
    132   (diagnostic remainder : err diagnostic remainder)
    133   (core unused : ok (sourceResolvePatternNode pattern core) t)
    134   (resolve child binders environment))
    135 sourceResolvePattern pattern binders environment = (let tag = sourceEquationTag pattern in
    136   let payload = sourceEquationPayload pattern in
    137   lazyBool (_ : sourceResolvePatternChild sourceResolvePattern pattern payload binders environment)
    138     (_ : lazyBool
    139       (_ : lazyResult (diagnostic remainder : err diagnostic remainder)
    140         (left unused : lazyResult (diagnostic remainder : err diagnostic remainder)
    141           (right unused : ok (sourceResolvePatternNode pattern (pair left right)) t)
    142           (sourceResolvePattern (snd payload) binders environment))
    143         (sourceResolvePattern (fst payload) binders environment))
    144       (_ : lazyBool
    145         (_ : lazyResult (diagnostic remainder : err diagnostic remainder)
    146           (child unused : ok (sourceResolvePatternNode pattern (pair (fst payload) child)) t)
    147           (sourceResolvePattern (snd payload) binders environment))
    148         (_ : lazyBool
    149           (_ : sourceResolvePatternChild sourceResolveName pattern payload binders environment)
    150           (_ : ok (sourceResolvePatternNode pattern payload) t) (equal? tag 7))
    151         (equal? tag 6)) (equal? tag 3)) (equal? tag 2))
    152 sourceResolveEquation resolve equation binders environment = (lazyResult
    153   (diagnostic remainder : err diagnostic remainder)
    154   (patterns unused : lazyResult (diagnostic remainder : err diagnostic remainder)
    155     (body unused : ok (sourceEquation patterns body) t)
    156     (resolve (snd equation)
    157       (append (reverse (sourceEquationCollect (fst equation) sourceEquationCaptures)) binders)
    158       environment))
    159   (sourceResolveElements (fst equation) sourceResolvePattern binders environment))
    160 sourceResolveEquationsWith lower resolve node binders environment = (lazyResult
    161   (diagnostic remainder : err diagnostic remainder)
    162   (_ unused : lazyResult (diagnostic remainder : err diagnostic remainder)
    163     (equations unused : lazyResult (diagnostic remainder : err diagnostic remainder)
    164       (core unused : ok (sourceCoreWithSpan core (sourceAstStart node) (sourceAstEnd node)) t)
    165       (lower equations))
    166     (sourceResolveElements (sourceAstPayload node) (sourceResolveEquation resolve) binders environment))
    167   (sourceEquationCheckGroup node))
    168 
    169 sourceResolveEquations = sourceResolveEquationsWith sourceLowerEquations
    170 
    171 sourceResolveOrdinary resolve node binders environment = (case sourceAstKind node of
    172   ^sourceAstLeafKind = ok (sourceCoreLeaf (sourceAstStart node) (sourceAstEnd node)) t
    173   ^sourceAstNameKind = sourceResolveName node binders environment
    174   ^sourceAstApplyKind = sourceResolveApply resolve node binders environment
    175   ^sourceAstLambdaKind = sourceResolveLambda resolve node binders environment
    176   ^sourceAstGroupKind = sourceResolveGroup resolve node binders environment
    177   ^sourceAstNumberKind = ok (sourceCoreNumber (sourceAstPayload node)
    178     (sourceAstStart node) (sourceAstEnd node)) t
    179   ^sourceAstStringKind = ok (sourceCoreString (sourceAstPayload node)
    180     (sourceAstStart node) (sourceAstEnd node)) t
    181   ^sourceAstListKind = sourceResolveList resolve node binders environment
    182   ^sourceAstLetKind = sourceResolveLocal resolve node binders environment
    183   ^sourceAstPipeKind = sourceResolvePipe resolve node binders environment
    184   ^sourceAstDoKind = sourceResolveDo resolve node binders environment
    185   ^sourceAstEquationsKind = sourceResolveEquations resolve node binders environment
    186   _ = err (parserDiagnostic 21 t (sourceAstKind node) (sourceAstStart node) t) node)
    187 
    188 resolveGateAst = (environment node :
    189   sourceResolve node t environment)
    190 
    191 resolveGateSource = (environment characters :
    192   parserMatchReply
    193     (diagnostic rest consumed committed : err diagnostic rest)
    194     (ast rest consumed committed : resolveGateAst environment ast)
    195     (parseGateSource characters))
    196 
    197 
    198 -- Resolve the scrutinee before arm pins/bodies, retaining source diagnostic
    199 -- order. Matching itself uses the same hygienic unary equation lowering.
    200 sourceResolveCase resolve node binders environment = (lazyResult
    201   (diagnostic rest : err diagnostic rest)
    202   (subject unused : lazyResult (diagnostic rest : err diagnostic rest)
    203     (matcher unused : ok (sourceCoreApply matcher subject (sourceAstStart node) (sourceAstEnd node)) t)
    204     (resolve (sourceAstCaseMatcher node) binders environment))
    205   (resolve (sourceAstCaseSubject node) binders environment))
    206 
    207 sourceResolveRec resolve node binders environment = (lazyBool
    208   (_ : lazyResult (diagnostic rest : err diagnostic rest)
    209     (worker unused : lazyResult (diagnostic rest : err diagnostic rest)
    210       (body unused : ok (sourceCoreApply
    211         (sourceCoreLambda body (sourceAstStart node) (sourceAstEnd node))
    212         (sourceCoreApply (sourceCoreExternal sourceCoreFix (sourceAstStart node) (sourceAstEnd node))
    213           worker (sourceAstStart node) (sourceAstEnd node))
    214         (sourceAstStart node) (sourceAstEnd node)) t)
    215       (resolve (sourceAstLetBody node) (pair (sourceAstLetName node) binders) environment))
    216     (resolve (sourceAstLambda (fst (sourceAstPayload node)) (sourceAstLetValue node)) binders environment))
    217   (_ : err (parserDiagnostic 48 "recursive function requires parameters"
    218     (sourceAstLetName node) (sourceTokenStart (fst (sourceAstPayload node))) t) node)
    219   (sourceAstFunction? (sourceAstLetValue node)))
    220 
    221 -- A single recursive entrypoint: helpers receive a visitor rather than
    222 -- relying on a mutually recursive group or a caller-supplied fixed point.
    223 sourceResolve node binders environment = (case sourceAstKind node of
    224   ^sourceAstCaseKind = sourceResolveCase sourceResolve node binders environment
    225   ^sourceAstRecKind = sourceResolveRec sourceResolve node binders environment
    226   _ = sourceResolveOrdinary sourceResolve node binders environment)
    227 
    228 -- Keep the ordinary visitor/backend unchanged. The stable visitor intercepts
    229 -- equation groups, including those reached through local/case/recursive bodies;
    230 -- all other resolution, lexical scope and diagnostic ordering are shared.
    231 sourceResolveStable node binders environment = (case sourceAstKind node of
    232   ^sourceAstCaseKind = sourceResolveCase sourceResolveStable node binders environment
    233   ^sourceAstRecKind = sourceResolveRec sourceResolveStable node binders environment
    234   ^sourceAstEquationsKind = sourceResolveEquationsWith sourceLowerStableEquations
    235     sourceResolveStable node binders environment
    236   _ = sourceResolveOrdinary sourceResolveStable node binders environment)
    237 resolveStableGateAst environment node = sourceResolveStable node t environment