tricu

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

bbb524d3e08a9961f8de6d8e2ab2e7dd47576b8ed78676a64d997bf65133b543.tri (11055B)

      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 sourceResolveEquations 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       (sourceLowerEquations equations))
    166     (sourceResolveElements (sourceAstPayload node) (sourceResolveEquation resolve) binders environment))
    167   (sourceEquationCheckGroup node))
    168 
    169 sourceResolveOrdinary resolve node binders environment = (case sourceAstKind node of
    170   ^sourceAstLeafKind = ok (sourceCoreLeaf (sourceAstStart node) (sourceAstEnd node)) t
    171   ^sourceAstNameKind = sourceResolveName node binders environment
    172   ^sourceAstApplyKind = sourceResolveApply resolve node binders environment
    173   ^sourceAstLambdaKind = sourceResolveLambda resolve node binders environment
    174   ^sourceAstGroupKind = sourceResolveGroup resolve node binders environment
    175   ^sourceAstNumberKind = ok (sourceCoreNumber (sourceAstPayload node)
    176     (sourceAstStart node) (sourceAstEnd node)) t
    177   ^sourceAstStringKind = ok (sourceCoreString (sourceAstPayload node)
    178     (sourceAstStart node) (sourceAstEnd node)) t
    179   ^sourceAstListKind = sourceResolveList resolve node binders environment
    180   ^sourceAstLetKind = sourceResolveLocal resolve node binders environment
    181   ^sourceAstPipeKind = sourceResolvePipe resolve node binders environment
    182   ^sourceAstDoKind = sourceResolveDo resolve node binders environment
    183   ^sourceAstEquationsKind = sourceResolveEquations resolve node binders environment
    184   _ = err (parserDiagnostic 21 t (sourceAstKind node) (sourceAstStart node) t) node)
    185 
    186 resolveGateAst = (environment node :
    187   sourceResolve node t environment)
    188 
    189 resolveGateSource = (environment characters :
    190   parserMatchReply
    191     (diagnostic rest consumed committed : err diagnostic rest)
    192     (ast rest consumed committed : resolveGateAst environment ast)
    193     (parseGateSource characters))
    194 
    195 
    196 -- Resolve the scrutinee before arm pins/bodies, retaining source diagnostic
    197 -- order. Matching itself uses the same hygienic unary equation lowering.
    198 sourceResolveCase resolve node binders environment = (lazyResult
    199   (diagnostic rest : err diagnostic rest)
    200   (subject unused : lazyResult (diagnostic rest : err diagnostic rest)
    201     (matcher unused : ok (sourceCoreApply matcher subject (sourceAstStart node) (sourceAstEnd node)) t)
    202     (resolve (sourceAstCaseMatcher node) binders environment))
    203   (resolve (sourceAstCaseSubject node) binders environment))
    204 
    205 sourceResolveRec resolve node binders environment = (lazyBool
    206   (_ : lazyResult (diagnostic rest : err diagnostic rest)
    207     (worker unused : lazyResult (diagnostic rest : err diagnostic rest)
    208       (body unused : ok (sourceCoreApply
    209         (sourceCoreLambda body (sourceAstStart node) (sourceAstEnd node))
    210         (sourceCoreApply (sourceCoreExternal sourceCoreFix (sourceAstStart node) (sourceAstEnd node))
    211           worker (sourceAstStart node) (sourceAstEnd node))
    212         (sourceAstStart node) (sourceAstEnd node)) t)
    213       (resolve (sourceAstLetBody node) (pair (sourceAstLetName node) binders) environment))
    214     (resolve (sourceAstLambda (fst (sourceAstPayload node)) (sourceAstLetValue node)) binders environment))
    215   (_ : err (parserDiagnostic 48 "recursive function requires parameters"
    216     (sourceAstLetName node) (sourceTokenStart (fst (sourceAstPayload node))) t) node)
    217   (sourceAstFunction? (sourceAstLetValue node)))
    218 
    219 -- A single recursive entrypoint: helpers receive a visitor rather than
    220 -- relying on a mutually recursive group or a caller-supplied fixed point.
    221 sourceResolve node binders environment = (case sourceAstKind node of
    222   ^sourceAstCaseKind = sourceResolveCase sourceResolve node binders environment
    223   ^sourceAstRecKind = sourceResolveRec sourceResolve node binders environment
    224   _ = sourceResolveOrdinary sourceResolve node binders environment)