tricu

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

d3f44ae8190c34e5b7bb543c5d491931ff44a8a4d7e60973e109c88b6563f8d9.tri (12266B)

      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 -- The innermost lexical binder has index zero. Both lookup workers recurse on
     12 -- their consumed list before touching the remaining state.
     13 sourceFindBinder_ self binders name index =
     14   lazyList
     15     (_ : nothing)
     16     (binder rest :
     17       lazyBool
     18         (_ : just index)
     19         (_ : self rest name (succ index))
     20         (equal? binder name))
     21     binders
     22 
     23 sourceFindBinder = (binders name : y sourceFindBinder_ binders name 0)
     24 
     25 -- CompileEnvironment is a list of (qualifiedName, already-resolved Tree).
     26 sourceFindExternal_ self entries name =
     27   lazyList
     28     (_ : nothing)
     29     (entry rest :
     30       lazyBool
     31         (_ : just (snd entry))
     32         (_ : self rest name)
     33         (equal? (fst entry) name))
     34     entries
     35 
     36 sourceFindExternal = (entries name : y sourceFindExternal_ entries name)
     37 
     38 sourceResolveName node binders environment =
     39   lazyMaybe
     40     (_ : lazyMaybe
     41       (_ : err
     42         (parserDiagnostic 20 (sourceAstPayload node) t
     43           (sourceAstStart node) t)
     44         node)
     45       (tree : ok (sourceCoreExternal tree
     46                     (sourceAstStart node) (sourceAstEnd node)) t)
     47       (sourceFindExternal environment (sourceAstPayload node)))
     48     (index : ok (sourceCoreBound index
     49                   (sourceAstStart node) (sourceAstEnd node)) t)
     50     (sourceFindBinder binders (sourceAstPayload node))
     51 
     52 sourceResolveApply self node binders environment =
     53   lazyResult
     54     (diagnostic rest : err diagnostic rest)
     55     (left unused :
     56       lazyResult
     57         (diagnostic rest : err diagnostic rest)
     58         (right unused :
     59           ok (sourceCoreApply left right
     60                 (sourceAstStart node) (sourceAstEnd node)) t)
     61         (self (snd (sourceAstPayload node)) binders environment))
     62     (self (fst (sourceAstPayload node)) binders environment)
     63 
     64 sourceResolvePipe self node binders environment =
     65   lazyResult
     66     (diagnostic remainder : err diagnostic remainder)
     67     (left unused :
     68       lazyResult
     69         (diagnostic remainder : err diagnostic remainder)
     70         (right unused :
     71           lazyBool
     72             (_ : ok (sourceCoreApply left right
     73                   (sourceAstStart node) (sourceAstEnd node)) t)
     74             (_ : ok (sourceCoreApply right left
     75                   (sourceAstStart node) (sourceAstEnd node)) t)
     76             (equal? (sourceAstPipeDirection node)
     77               sourceTokenPipeBackward))
     78         (self (sourceAstPipeRight node) binders environment))
     79     (self (sourceAstPipeLeft node) binders environment)
     80 
     81 sourceResolveLambda self node binders environment =
     82   lazyResult
     83     (diagnostic rest : err diagnostic rest)
     84     (body unused :
     85       ok (sourceCoreLambda body
     86             (sourceAstStart node) (sourceAstEnd node)) t)
     87     (self (snd (sourceAstPayload node))
     88       (pair (fst (sourceAstPayload node)) binders) environment)
     89 
     90 sourceResolveGroup self node binders environment =
     91   lazyResult
     92     (diagnostic rest : err diagnostic rest)
     93     (body unused :
     94       ok (sourceCoreWithSpan body
     95             (sourceAstStart node) (sourceAstEnd node)) t)
     96     (self (sourceAstPayload node) binders environment)
     97 
     98 -- Resolve the value outside the new binder, and the body inside it. The
     99 -- core representation needs no special let node: (name : body) value.
    100 sourceResolveDo self node binders environment =
    101   lazyResult
    102     (diagnostic remainder : err diagnostic remainder)
    103     (core remainder : ok
    104       (sourceCoreWithSpan core (sourceAstStart node) (sourceAstEnd node)) t)
    105     (self (sourceAstDoLower node) binders environment)
    106 
    107 sourceResolveLocal self node binders environment =
    108   lazyResult
    109     (diagnostic remainder : err diagnostic remainder)
    110     (value unused :
    111       lazyResult
    112         (diagnostic remainder : err diagnostic remainder)
    113         (body unused : ok
    114           (sourceCoreApply
    115             (sourceCoreLambda body (sourceAstStart node) (sourceAstEnd node))
    116             value (sourceAstStart node) (sourceAstEnd node)) t)
    117         (self (sourceAstLetBody node)
    118           (pair (sourceAstLetName node) binders) environment))
    119     (self (sourceAstLetValue node) binders environment)
    120 
    121 -- Resolve children in source order so the first missing name keeps its own
    122 -- location. Accumulate in reverse with constant-time cons, then reverse once.
    123 sourceResolveElements_ self nodes resolve binders environment reversed =
    124   lazyList
    125     (_ : ok (reverse reversed) t)
    126     (element rest :
    127       lazyResult
    128         (diagnostic remainder : err diagnostic remainder)
    129         (core remainder :
    130           self rest resolve binders environment (pair core reversed))
    131         (resolve element binders environment))
    132     nodes
    133 
    134 sourceResolveElements = (nodes resolve binders environment :
    135   y sourceResolveElements_ nodes resolve binders environment t)
    136 
    137 sourceResolveList self node binders environment =
    138   lazyResult
    139     (diagnostic remainder : err diagnostic remainder)
    140     (elements remainder : ok
    141       (sourceCoreList elements (sourceAstStart node) (sourceAstEnd node)) t)
    142     (sourceResolveElements (sourceAstPayload node) self binders environment)
    143 
    144 -- Pins resolve against surrounding binders only; equation captures are
    145 -- introduced together for the body, in the lowerer's reverse lexical order.
    146 sourceResolvePatternNode pattern payload = (sourcePatternNode
    147   (sourceEquationTag pattern) payload (sourceAstStart pattern))
    148 sourceResolvePatternChild self pattern child binders environment = (lazyResult
    149   (diagnostic remainder : err diagnostic remainder)
    150   (core unused : ok (sourceResolvePatternNode pattern core) t)
    151   (self child binders environment))
    152 sourceResolvePattern_ self pattern binders environment = (let tag = sourceEquationTag pattern in
    153   let payload = sourceEquationPayload pattern in
    154   lazyBool (_ : sourceResolvePatternChild self pattern payload binders environment)
    155     (_ : lazyBool
    156       (_ : lazyResult (diagnostic remainder : err diagnostic remainder)
    157         (left unused : lazyResult (diagnostic remainder : err diagnostic remainder)
    158           (right unused : ok (sourceResolvePatternNode pattern (pair left right)) t)
    159           (self (snd payload) binders environment))
    160         (self (fst payload) binders environment))
    161       (_ : lazyBool
    162         (_ : lazyResult (diagnostic remainder : err diagnostic remainder)
    163           (child unused : ok (sourceResolvePatternNode pattern (pair (fst payload) child)) t)
    164           (self (snd payload) binders environment))
    165         (_ : lazyBool
    166           (_ : sourceResolvePatternChild sourceResolveName pattern payload binders environment)
    167           (_ : ok (sourceResolvePatternNode pattern payload) t) (equal? tag 7))
    168         (equal? tag 6)) (equal? tag 3)) (equal? tag 2))
    169 sourceResolvePattern pattern binders environment = y sourceResolvePattern_ pattern binders environment
    170 sourceResolveEquation resolve equation binders environment = (lazyResult
    171   (diagnostic remainder : err diagnostic remainder)
    172   (patterns unused : lazyResult (diagnostic remainder : err diagnostic remainder)
    173     (body unused : ok (sourceEquation patterns body) t)
    174     (resolve (snd equation)
    175       (append (reverse (sourceEquationCollect (fst equation) sourceEquationCaptures)) binders)
    176       environment))
    177   (sourceResolveElements (fst equation) sourceResolvePattern binders environment))
    178 sourceResolveEquations resolve node binders environment = (lazyResult
    179   (diagnostic remainder : err diagnostic remainder)
    180   (_ unused : lazyResult (diagnostic remainder : err diagnostic remainder)
    181     (equations unused : lazyResult (diagnostic remainder : err diagnostic remainder)
    182       (core unused : ok (sourceCoreWithSpan core (sourceAstStart node) (sourceAstEnd node)) t)
    183       (sourceLowerEquations equations))
    184     (sourceResolveElements (sourceAstPayload node) (sourceResolveEquation resolve) binders environment))
    185   (sourceEquationCheckGroup node))
    186 
    187 sourceResolveOrdinary self node binders environment =
    188   lazyBool
    189     (_ : ok (sourceCoreLeaf
    190           (sourceAstStart node) (sourceAstEnd node)) t)
    191     (_ : lazyBool
    192       (_ : sourceResolveName node binders environment)
    193       (_ : lazyBool
    194         (_ : sourceResolveApply self node binders environment)
    195         (_ : lazyBool
    196           (_ : sourceResolveLambda self node binders environment)
    197           (_ : lazyBool
    198             (_ : sourceResolveGroup self node binders environment)
    199             (_ : lazyBool
    200               (_ : ok (sourceCoreNumber (sourceAstPayload node)
    201                     (sourceAstStart node) (sourceAstEnd node)) t)
    202               (_ : lazyBool
    203                 (_ : ok (sourceCoreString (sourceAstPayload node)
    204                       (sourceAstStart node) (sourceAstEnd node)) t)
    205                 (_ : lazyBool
    206                   (_ : sourceResolveList self node binders environment)
    207                   (_ : lazyBool
    208                     (_ : sourceResolveLocal self node binders environment)
    209                     (_ : lazyBool
    210                       (_ : sourceResolvePipe self node binders environment)
    211                       (_ : lazyBool
    212                         (_ : sourceResolveDo self node binders environment)
    213                         (_ : lazyBool
    214                           (_ : sourceResolveEquations self node binders environment)
    215                           (_ : err (parserDiagnostic 21 t (sourceAstKind node)
    216                             (sourceAstStart node) t) node)
    217                           (equal? (sourceAstKind node) sourceAstEquationsKind))
    218                         (equal? (sourceAstKind node) sourceAstDoKind))
    219                       (equal? (sourceAstKind node) sourceAstPipeKind))
    220                     (equal? (sourceAstKind node) sourceAstLetKind))
    221                   (equal? (sourceAstKind node) sourceAstListKind))
    222                 (equal? (sourceAstKind node) sourceAstStringKind))
    223               (equal? (sourceAstKind node) sourceAstNumberKind))
    224             (equal? (sourceAstKind node) sourceAstGroupKind))
    225           (equal? (sourceAstKind node) sourceAstLambdaKind))
    226         (equal? (sourceAstKind node) sourceAstApplyKind))
    227       (equal? (sourceAstKind node) sourceAstNameKind))
    228     (equal? (sourceAstKind node) sourceAstLeafKind)
    229 
    230 resolveGateAst = (environment node :
    231   y sourceResolve_ node t environment)
    232 
    233 resolveGateSource = (environment characters :
    234   parserMatchReply
    235     (diagnostic rest consumed committed : err diagnostic rest)
    236     (ast rest consumed committed : resolveGateAst environment ast)
    237     (parseGateSource characters))
    238 
    239 
    240 -- Resolve the scrutinee before arm pins/bodies, retaining source diagnostic
    241 -- order. Matching itself uses the same hygienic unary equation lowering.
    242 sourceResolveCase self node binders environment = (lazyResult
    243   (diagnostic rest : err diagnostic rest)
    244   (subject unused : lazyResult (diagnostic rest : err diagnostic rest)
    245     (matcher unused : ok (sourceCoreApply matcher subject (sourceAstStart node) (sourceAstEnd node)) t)
    246     (self (sourceAstCaseMatcher node) binders environment))
    247   (self (sourceAstCaseSubject node) binders environment))
    248 
    249 sourceResolveRec self node binders environment = (lazyBool
    250   (_ : lazyResult (diagnostic rest : err diagnostic rest)
    251     (worker unused : lazyResult (diagnostic rest : err diagnostic rest)
    252       (body unused : ok (sourceCoreApply
    253         (sourceCoreLambda body (sourceAstStart node) (sourceAstEnd node))
    254         (sourceCoreApply (sourceCoreExternal sourceCoreFix (sourceAstStart node) (sourceAstEnd node))
    255           worker (sourceAstStart node) (sourceAstEnd node))
    256         (sourceAstStart node) (sourceAstEnd node)) t)
    257       (self (sourceAstLetBody node) (pair (sourceAstLetName node) binders) environment))
    258     (self (sourceAstLambda (fst (sourceAstPayload node)) (sourceAstLetValue node)) binders environment))
    259   (_ : err (parserDiagnostic 48 "recursive function requires parameters"
    260     (sourceAstLetName node) (sourceTokenStart (fst (sourceAstPayload node))) t) node)
    261   (sourceAstFunction? (sourceAstLetValue node)))
    262 
    263 sourceResolve_ self node binders environment = (let
    264   resolve ^sourceAstCaseKind = sourceResolveCase self node binders environment
    265   resolve ^sourceAstRecKind = sourceResolveRec self node binders environment
    266   resolve _ = sourceResolveOrdinary self node binders environment
    267   in resolve (sourceAstKind node))