tricu

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

staged-conditional-experiment.tri (6596B)

      1 !import prelude *
      2 !import parser *
      3 !import source_core *
      4 !import source_ast *
      5 !import source_pattern *
      6 !import source_compile *
      7 !import source_resolve *
      8 !import source_program *
      9 !import source_order *
     10 !import source_unit *
     11 !import source_staging_experiment as S
     12 !import source_staged_list_experiment as L
     13 !export *
     14 -- Experimental source profile, not imported by any canonical compiler unit.
     15 -- The focused preparation replaces this with an exact flat manifest pin.
     16 
     17 -- A syntax-only external binding. It must never survive into executable code.
     18 -- Recognition occurs AFTER lexical resolution: local shadowing stays ordinary.
     19 stagedIfMarker = "tricu.experimental.stageIf.v1"
     20 stagedIfBinding = pair "stageIf" stagedIfMarker
     21 stagedSourceBindings = pair stagedIfBinding L.stagedListBindings
     22 stagedSourceMarker? tree = or? (equal? tree stagedIfMarker) (or? (equal? tree L.stagedListMarker) (equal? tree L.stagedNextMarker))
     23 stagedIfMarker? node = (and? (equal? (sourceCoreKind node) sourceCoreExternalKind)
     24   (equal? (sourceCorePayload node) stagedIfMarker))
     25 stagedIfError node = err (parserDiagnostic 48 "fully applied stageIf condition yes no"
     26   t (sourceCoreStart node) t) node
     27 
     28 -- Finite inspection of a three-argument application spine, not recursive
     29 -- slicing. A fourth argument is an ordinary application to the selected result.
     30 stagedIfFirst node yes no = (lazyBool
     31   (_ : lazyBool
     32     (_ : just (pair (snd (sourceCorePayload node)) (pair yes no)))
     33     (_ : nothing) (stagedIfMarker? (fst (sourceCorePayload node))))
     34   (_ : nothing) (equal? (sourceCoreKind node) sourceCoreApplyKind))
     35 stagedIfSecond node no = (lazyBool
     36   (_ : stagedIfFirst (fst (sourceCorePayload node)) (snd (sourceCorePayload node)) no)
     37   (_ : nothing) (equal? (sourceCoreKind node) sourceCoreApplyKind))
     38 stagedIfCall node = (lazyBool
     39   (_ : stagedIfSecond (fst (sourceCorePayload node)) (snd (sourceCorePayload node)))
     40   (_ : nothing) (equal? (sourceCoreKind node) sourceCoreApplyKind))
     41 
     42 stagedIfChildren_ self children lower = (lazyList (_ : ok [] t)
     43   (child rest : lazyResult (problem unused : err problem unused)
     44     (head unused : lazyResult (problem unused : err problem unused)
     45       (tail unused : ok (pair head tail) t) (self rest lower)) (lower child)) children)
     46 stagedIfChildren children lower = y stagedIfChildren_ children lower
     47 stagedIfRewrite_ self node = (lazyMaybe
     48   (_ : lazyBool (_ : stagedIfError node)
     49     (_ : let kind = sourceCoreKind node in let payload = sourceCorePayload node in
     50     lazyBool
     51       (_ : lazyResult (problem rest : err problem rest)
     52         (left unused : lazyResult (problem rest : err problem rest)
     53           (right unused : ok (sourceCoreApply left right (sourceCoreStart node) (sourceCoreEnd node)) t)
     54           (self (snd payload))) (self (fst payload)))
     55       (_ : lazyBool
     56         (_ : lazyResult (problem rest : err problem rest)
     57           (body unused : ok (sourceCoreLambda body (sourceCoreStart node) (sourceCoreEnd node)) t)
     58           (self payload))
     59         (_ : lazyBool
     60           (_ : lazyResult (problem rest : err problem rest)
     61             (items unused : ok (sourceCoreList items (sourceCoreStart node) (sourceCoreEnd node)) t)
     62             (stagedIfChildren payload self))
     63           (_ : ok node t) (equal? kind sourceCoreListKind))
     64         (equal? kind sourceCoreLambdaKind))
     65       (equal? kind sourceCoreApplyKind)) (stagedIfMarker? node))
     66   (parts : lazyResult (problem rest : err problem rest)
     67     (condition unused : lazyResult (problem rest : err problem rest)
     68       (yes unused : lazyResult (problem rest : err problem rest)
     69         (no unused : ok (S.stageBranch condition yes no) t) (self (snd (snd parts))))
     70       (self (fst (snd parts)))) (self (fst parts)))
     71   (stagedIfCall node))
     72 stagedIfRewrite node = y stagedIfRewrite_ node
     73 stagedIfCompileCore core = (lazyResult (problem rest : err problem rest)
     74   (rewritten unused : lazyResult (problem rest : err problem rest)
     75     (listCore rest : sourceCompileCore (S.stageBody listCore)) (L.stagedListRewrite rewritten)) (stagedIfRewrite core))
     76 
     77 -- Reject a supplied marker collision and top-level rebinding. Local binders
     78 -- may shadow stageIf: their resolved CoreBound heads cannot be mistaken for it.
     79 stagedIfEnvironment_ self entries = (lazyList (_ : ok t t)
     80   (entry rest : lazyBool
     81     (_ : err (parserDiagnostic 48 "stageIf is an experimental compiler binding" (fst entry) t t) t)
     82     (_ : self rest)
     83     (or? (or? (equal? (fst entry) "stageIf")
     84       (or? (equal? (fst entry) "stageList") (equal? (fst entry) "stageNext")))
     85       (stagedSourceMarker? (snd entry)))) entries)
     86 stagedIfEnvironment environment = y stagedIfEnvironment_ environment
     87 stagedIfOrdered_ self names definitions external compiled = (lazyList (_ : ok compiled t)
     88   (name rest : lazyMaybe
     89     (_ : err (parserDiagnostic 33 name t t t) name)
     90     (definition : lazyResult (problem unused : err problem unused)
     91       (core unused : lazyResult (problem unused : err problem unused)
     92         (tree unused : lazyBool
     93           (_ : err (parserDiagnostic 48 "reserved stageIf marker value" name
     94             (sourceDefinitionPosition definition) t) t)
     95           (_ : self rest definitions external (pair (pair name tree) compiled))
     96           (stagedSourceMarker? tree))
     97         (stagedIfCompileCore core))
     98       (resolveGateAst (append compiled external) (sourceDefinitionBody definition)))
     99     (sourceFindDefinition definitions name)) names)
    100 
    101 -- Definitions-only unit boundary; dependency ordering and ordinary syntax are
    102 -- shared with the portable compiler. Headers/import IO remain outside this unit.
    103 stagedIfCompileDefinitions environment characters = (lazyResult (problem rest : err problem rest)
    104   (_ unused : parserMatchReply (problem rest consumed committed : err problem rest)
    105     (program rest consumed committed : lazyMaybe
    106       (_ : lazyResult (problem rest : err problem rest)
    107         (_ unused : lazyResult
    108           (problem rest : err problem rest)
    109           (ordered unused : lazyResult (problem rest : err problem rest)
    110             (compiled unused : ok (reverse compiled) t)
    111             (y stagedIfOrdered_ ordered (sourceProgramDefinitions program)
    112               (append stagedSourceBindings environment) []))
    113           (orderGateProgram (append stagedSourceBindings environment) program))
    114         (sourceModuleCheckShadows (append stagedSourceBindings environment) (sourceProgramDefinitions program)))
    115       (expression : err (parserDiagnostic 42 "definitions only" t (sourceAstStart expression) t) expression)
    116       (sourceProgramFinal program)) (parseGateProgram characters)) (stagedIfEnvironment environment))