tricu

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

bfa6059c7986f263df801f70879da4870ecca95bdbb0b5726d051e92b695cca4.tri (7767B)

      1 !import prelude *
      2 !import parser *
      3 !import graph *
      4 !import source_program *
      5 !import source_resolve *
      6 !import source_ast *
      7 !import source_equations *
      8 !export *
      9 
     10 sourceFindDefinition definitions name = (let rec
     11   find definitions = (lazyList (_ : nothing)
     12     (definition rest : lazyBool (_ : just definition)
     13       (_ : find rest) (equal? (sourceDefinitionName definition) name)) definitions)
     14   in find definitions)
     15 
     16 -- Free-name collection returns located name AST nodes, so a missing-name
     17 -- diagnostic retains the original source position rather than a string key.
     18 sourceFreeList elements visit bound = concatMap (element : visit element bound) elements
     19 
     20 -- Pins see the surrounding scope, never the equation's captures. Keep pins
     21 -- before the body and retain repeated located occurrences in traversal order.
     22 sourceFreeEquations equations visit bound = (concatMap
     23   (equation : append
     24     (sourceFreeList (sourceEquationCollect (fst equation) sourceEquationPins) visit bound)
     25     (visit (snd equation)
     26       (append (reverse (sourceEquationCollect (fst equation) sourceEquationCaptures)) bound)))
     27   equations)
     28 
     29 sourceFreeOrdinary visit node bound = (case sourceAstKind node of
     30   ^sourceAstNameKind = lazyMaybe (_ : [node]) (_ : t)
     31     (sourceFindBinder bound (sourceAstPayload node))
     32   ^sourceAstApplyKind = append (visit (fst (sourceAstPayload node)) bound)
     33     (visit (snd (sourceAstPayload node)) bound)
     34   ^sourceAstLambdaKind = visit (snd (sourceAstPayload node))
     35     (pair (fst (sourceAstPayload node)) bound)
     36   ^sourceAstGroupKind = visit (sourceAstPayload node) bound
     37   ^sourceAstListKind = sourceFreeList (sourceAstPayload node) visit bound
     38   ^sourceAstLetKind = append (visit (sourceAstLetValue node) bound)
     39     (visit (sourceAstLetBody node) (pair (sourceAstLetName node) bound))
     40   ^sourceAstPipeKind = append (visit (sourceAstPipeLeft node) bound)
     41     (visit (sourceAstPipeRight node) bound)
     42   ^sourceAstDoKind = visit (sourceAstDoLower node) bound
     43   ^sourceAstEquationsKind = sourceFreeEquations (sourceAstPayload node) visit bound
     44   _ = t)
     45 
     46 sourceFreeNames node = sourceFreeVisit node t
     47 
     48 sourceCheckDuplicates definitions = (let rec
     49   walk definitions seen = (lazyList
     50       (_ : ok t t)
     51       (definition rest :
     52         lazyMaybe
     53           (_ : walk rest (pair definition seen))
     54           (prior : err
     55             (parserDiagnostic 30 (sourceDefinitionName definition)
     56               (sourceDefinitionName prior)
     57               (sourceDefinitionPosition definition) t)
     58             definition)
     59           (sourceFindDefinition seen (sourceDefinitionName definition)))
     60       definitions)
     61   in walk definitions t)
     62 
     63 sourceCheckNames names definitions environment = (let rec
     64   walk names = (lazyList
     65       (_ : ok t t)
     66       (node rest :
     67         lazyMaybe
     68           (_ : lazyMaybe
     69             (_ : err
     70               (parserDiagnostic 20 (sourceAstPayload node) t
     71                 (sourceAstStart node) t)
     72               node)
     73             (value : walk rest)
     74             (sourceFindExternal environment (sourceAstPayload node)))
     75           (definition : walk rest)
     76           (sourceFindDefinition definitions (sourceAstPayload node)))
     77       names)
     78   in walk names)
     79 
     80 sourceCheckDefinitionNames definitions environment = (let rec
     81   walk pending = (lazyList
     82       (_ : ok t t)
     83       (definition rest :
     84         lazyResult
     85           (diagnostic node : err diagnostic node)
     86           (ignored unused : walk rest)
     87           (lazyResult (diagnostic remainder : err diagnostic remainder)
     88             (_ unused : sourceCheckNames (sourceFreeNames (sourceDefinitionBody definition))
     89               definitions environment)
     90             (sourceEquationValidate (sourceDefinitionBody definition))))
     91       pending)
     92   in walk definitions)
     93 
     94 sourceCheckFinalNames final definitions environment =
     95   lazyMaybe
     96     (_ : ok t t)
     97     (expression : lazyResult (diagnostic remainder : err diagnostic remainder)
     98       (_ unused : sourceCheckNames (sourceFreeNames expression) definitions environment)
     99       (sourceEquationValidate expression))
    100     final
    101 
    102 sourceDependencyNames names definitions = (let rec
    103   walk names = (lazyList
    104       (_ : t)
    105       (node rest :
    106         lazyMaybe
    107           (_ : walk rest)
    108           (definition : pair (sourceAstPayload node) (walk rest))
    109           (sourceFindDefinition definitions (sourceAstPayload node)))
    110       names)
    111   in walk names)
    112 
    113 sourceDefinitionGraph definitions = (map
    114   (definition : pair (sourceDefinitionName definition)
    115     (sourceDependencyNames (sourceFreeNames (sourceDefinitionBody definition)) definitions))
    116   definitions)
    117 
    118 -- Validate each located free name and retain its local edge in the same pass.
    119 -- Do not deduplicate/reorder edges: their order determines cycle witnesses.
    120 -- A local definition wins over an external with the same spelling.
    121 sourceAnalyzeNames names definitions environment = (let rec
    122   walk names = (lazyList
    123     (_ : ok t t)
    124     (node rest : lazyMaybe
    125       (_ : lazyMaybe
    126         (_ : err (parserDiagnostic 20 (sourceAstPayload node) t
    127           (sourceAstStart node) t) node)
    128         (_ : walk rest)
    129         (sourceFindExternal environment (sourceAstPayload node)))
    130       (_ : lazyResult
    131         (diagnostic missing : err diagnostic missing)
    132         (dependencies unused : ok (pair (sourceAstPayload node) dependencies) t)
    133         (walk rest))
    134       (sourceFindDefinition definitions (sourceAstPayload node))) names)
    135   in walk names)
    136 
    137 -- Equation validation still precedes names in each definition. Only after all
    138 -- definitions succeed may final-expression validation and graph sorting run.
    139 -- The reversed accumulator is constructor-only; reverse once on completion.
    140 sourceAnalyzeDefinitions definitions environment = (let rec
    141   walk pending reversed = (lazyList
    142     (_ : ok (reverse reversed) t)
    143     (definition rest : lazyResult
    144       (diagnostic remainder : err diagnostic remainder)
    145       (_ unused : lazyResult
    146         (diagnostic missing : err diagnostic missing)
    147         (dependencies unused : walk rest
    148           (pair (pair (sourceDefinitionName definition) dependencies) reversed))
    149         (sourceAnalyzeNames (sourceFreeNames (sourceDefinitionBody definition))
    150           definitions environment))
    151       (sourceEquationValidate (sourceDefinitionBody definition))) pending)
    152   in walk definitions t)
    153 
    154 sourceOrderCycle definitions name =
    155   lazyMaybe
    156     (_ : parserDiagnostic 31 "acyclic" name t (pair name t))
    157     (definition : parserDiagnostic 31 "acyclic" name
    158       (sourceDefinitionPosition definition) (pair name t))
    159     (sourceFindDefinition definitions name)
    160 
    161 orderGateProgram environment program = (let definitions = sourceProgramDefinitions program in
    162   let proceed reply next = (lazyResult
    163     (diagnostic rest : err diagnostic rest) (value unused : next value) reply) in
    164   do proceed
    165     sourceCheckDuplicates definitions
    166     graph <- sourceAnalyzeDefinitions definitions environment
    167     sourceCheckFinalNames (sourceProgramFinal program) definitions environment
    168     (lazyResult
    169       (cycle unused : err (sourceOrderCycle definitions cycle) t)
    170       (names unused : ok names t)
    171       (graphSort graph)))
    172 
    173 orderGateSource environment characters =
    174   parserMatchReply
    175     (diagnostic rest consumed committed : err diagnostic rest)
    176     (program rest consumed committed : orderGateProgram environment program)
    177     (parseGateProgram characters)
    178 
    179 
    180 sourceFreeVisit node bound = (case sourceAstKind node of
    181   ^sourceAstCaseKind = append
    182     (sourceFreeVisit (sourceAstCaseSubject node) bound)
    183     (sourceFreeVisit (sourceAstCaseMatcher node) bound)
    184   ^sourceAstRecKind = (let nested = pair (sourceAstLetName node) bound in
    185     append (sourceFreeVisit (sourceAstLetValue node) nested)
    186       (sourceFreeVisit (sourceAstLetBody node) nested))
    187   _ = sourceFreeOrdinary sourceFreeVisit node bound)