tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

program.tri (9762B)

      1 !import prelude *
      2 !import parser *
      3 !import source_parser *
      4 !import source_lexer *
      5 !import source_ast *
      6 !import source_equations *
      7 !export *
      8 
      9 -- Program = pair definitions (Maybe finalExpression).
     10 -- Definition = pair locatedNameToken body. Contiguous plain equations
     11 -- coalesce into one located equation body; unique all-name singleton heads
     12 -- take the ordinary lambda path. Program parsing is distinct from the
     13 -- single-expression gate.
     14 sourceProgramDefinitions program    = fst program
     15 sourceProgramFinal       program    = snd program
     16 sourceDefinitionName     definition = sourceTokenPayload (fst definition)
     17 sourceDefinitionPosition definition = sourceTokenStart (fst definition)
     18 sourceDefinitionBody     definition = snd definition
     19 
     20 sourceProgramSkipNewlines =
     21   parserMap (_ : t) (parserMany (sourceGateExpect sourceTokenNewline))
     22 
     23 -- Plain and annotated heads share the owning definition's layout boundary.
     24 sourceProgramDefinitionValue column =
     25   sourceGateParseLayoutValue (sourceGateExprIndented column)
     26     (sourceGateLayoutIndented column) "definition body"
     27 
     28 -- Look ahead across the head (including delimited pattern newlines). This
     29 -- distinguishes `f t` (expression) from `f x = x` (definition), without
     30 -- consuming tokens or trying a partially consumed alternative.
     31 sourceProgramAssignOnLine? tokens = sourceEquationAssignLine? tokens
     32 
     33 sourceProgramDefinitionHead? tokens =
     34   lazyList
     35     (_ : false)
     36     (token rest :
     37       lazyBool
     38         (_ : sourceProgramAssignOnLine? rest)
     39         (_ : false)
     40         (equal? (sourceTokenKind token) sourceTokenName))
     41     tokens
     42 
     43 -- Contract annotations on plain definition heads. Contract expressions are
     44 -- ordinary names or parenthesized applications. Lowering preserves Result
     45 -- short-circuiting and passes each accepted/transformed value to the body.
     46 sourceProgramContract =
     47   parserOr (sourceGateParseGroup (tokens : sourceGateExprWithLayout tokens sourceGateLayoutNested))
     48     (parserMap sourceAstName (sourceGateExpect sourceTokenName))
     49 
     50 -- Argument = pair (Maybe namedBinderToken) (Maybe contractExpression).
     51 sourceProgramArgNamed input =
     52   parserBind (sourceGateExpect sourceTokenName) (name :
     53     parserMap (contract : pair (just name) contract)
     54       (parserOptional (parserThen (sourceGateExpect sourceTokenAt)
     55         sourceProgramContract))) input
     56 
     57 sourceProgramArgPhantom =
     58   parserMap (contract : pair nothing (just contract))
     59     (parserThen (sourceGateExpect sourceTokenAt) sourceProgramContract)
     60 
     61 sourceProgramArgument = parserOr sourceProgramArgPhantom sourceProgramArgNamed
     62 
     63 sourceProgramSynthetic name node =
     64   sourceToken sourceTokenName name
     65     (sourceAstStart node) (sourceAstStart node)
     66 
     67 sourceProgramName name node = sourceAstName (sourceProgramSynthetic name node)
     68 sourceProgramApply2 function first second =
     69   sourceAstApply (sourceAstApply function first) second
     70 sourceProgramApply3 function first second third =
     71   sourceAstApply (sourceProgramApply2 function first second) third
     72 
     73 sourceProgramChecked contract value =
     74   sourceProgramApply2 (sourceProgramName "withContract" contract) contract value
     75 
     76 sourceProgramFailure msg =
     77   sourceProgramApply2
     78     (sourceProgramName "err" msg) msg
     79     (sourceAstLeaf (sourceProgramSynthetic "t" msg))
     80 
     81 sourceProgramOnFailure node =
     82   sourceAstLambda
     83     (sourceProgramSynthetic "msg" node)
     84     (sourceAstLambda (sourceProgramSynthetic "_" node)
     85       (sourceProgramFailure (sourceProgramName "msg" node)))
     86 
     87 -- Earlier failed arguments must still accept the remaining arguments before
     88 -- producing the error, just like the historical Haskell lowering.
     89 sourceProgramAbsorbFailure node =
     90   sourceAstLambda
     91     (sourceProgramSynthetic "msg" node)
     92     (sourceAstLambda (sourceProgramSynthetic "_" node)
     93       (sourceAstLambda (sourceProgramSynthetic "_" node)
     94         (sourceProgramFailure (sourceProgramName "msg" node))))
     95 
     96 sourceProgramReturn contract body =
     97   lazyMaybe
     98     (_ : body)
     99     (c : sourceProgramApply3
    100       (sourceProgramName "matchResult" c)
    101       (sourceProgramOnFailure c)
    102       (sourceAstLambda (sourceProgramSynthetic "r" c)
    103         (sourceAstLambda (sourceProgramSynthetic "_" c)
    104           (sourceProgramName "r" c)))
    105       (sourceProgramChecked c body))
    106     contract
    107 
    108 sourceProgramArgName arg index anchor =
    109   lazyMaybe
    110     (_ : sourceProgramSynthetic
    111       (if (isZero_? index) "x" (if (equal? index 1) "y" "z")) anchor)
    112     (token : token)
    113     (fst arg)
    114 
    115 sourceProgramRawApply args raw = (let rec
    116   walk args raw index =
    117     lazyList
    118       (_ : raw)
    119       (arg rest : walk rest
    120         (sourceAstApply raw
    121           (sourceAstName (sourceProgramArgName arg index raw)))
    122         (succ index))
    123       args
    124   in walk args raw 0)
    125 
    126 sourceProgramWrapArgs args body = (let rec
    127   walk args index =
    128     lazyList
    129       (_ : body)
    130       (arg rest :
    131         sourceAstLambda (sourceProgramArgName arg index body)
    132           (lazyMaybe
    133             (_ : walk rest (succ index))
    134             (c : sourceProgramApply3
    135               (sourceProgramName "matchResult" c)
    136               (lazyList
    137                 (_ : sourceProgramOnFailure c)
    138                 (other tail : sourceProgramAbsorbFailure c)
    139                 rest)
    140               (sourceAstLambda (sourceProgramArgName arg index body)
    141                 (sourceAstLambda (sourceProgramSynthetic "_" c)
    142                   (walk rest (succ index))))
    143               (sourceProgramChecked c
    144                 (sourceAstName (sourceProgramArgName arg index body))))
    145             (snd arg)))
    146       args
    147   in walk args 0)
    148 
    149 sourceProgramAnyContract? args =
    150   lazyList
    151     (_ : false)
    152     (arg rest : lazyMaybe
    153       (_ : sourceProgramAnyContract? rest)
    154       (contract : true)
    155       (snd arg))
    156     args
    157 
    158 sourceProgramAnyPhantom? args =
    159   lazyList
    160     (_ : false)
    161     (arg rest : lazyMaybe
    162       (_ : true)
    163       (name : sourceProgramAnyPhantom? rest)
    164       (fst arg))
    165     args
    166 
    167 sourceProgramAllPhantom? args =
    168   lazyList
    169     (_ : true)
    170     (arg rest : lazyMaybe
    171       (_ : sourceProgramAllPhantom? rest)
    172       (name : false)
    173       (fst arg))
    174     args
    175 
    176 sourceProgramPlainArgs args body =
    177   lazyList
    178     (_ : body)
    179     (arg rest : sourceAstLambda (sourceProgramArgName arg 0 body)
    180       (sourceProgramPlainArgs rest body))
    181     args
    182 
    183 sourceProgramLowerDefinition name args result body =
    184   lazyBool
    185     (_ : lazyBool
    186       (_ : sourceAstLocal
    187         (sourceToken sourceTokenName
    188           (append "_" (append (sourceTokenPayload name) "_raw"))
    189           (sourceTokenStart name) (sourceTokenEnd name))
    190         body
    191         (sourceProgramWrapArgs args
    192           (sourceProgramReturn result
    193             (sourceProgramRawApply args
    194               (sourceProgramName
    195                 (append "_" (append (sourceTokenPayload name) "_raw"))
    196                 body))))
    197         (sourceTokenStart name) (sourceAstEnd body))
    198       (_ : sourceProgramWrapArgs args (sourceProgramReturn result body))
    199       (sourceProgramAnyPhantom? args))
    200     (_ : sourceProgramPlainArgs args body)
    201     (or? (sourceProgramAnyContract? args)
    202       (lazyMaybe (_ : false) (contract : true) result))
    203 
    204 sourceProgramParseAnnotatedBinding input =
    205   parserBind (sourceGateExpect sourceTokenName) (name :
    206     parserBind (parserMany sourceProgramArgument) (args :
    207       (remaining : lazyBool
    208         (_ : parserThen (sourceGateExpect sourceTokenAssign)
    209           (parserBind (parserOptional
    210             (parserThen (sourceGateExpect sourceTokenAt)
    211               sourceProgramContract)) (result :
    212             parserMap (body : pair name
    213               (sourceProgramLowerDefinition name args result body))
    214               (sourceProgramDefinitionValue (sourcePositionColumn (sourceTokenStart name))))) remaining)
    215         (_ : parserReplyFail
    216           (parserDiagnostic 47 "supported contract head" t
    217             (sourceTokenStart name) t) remaining true false)
    218         (or? (not? (sourceProgramAnyPhantom? args))
    219           (and? (sourceProgramAllPhantom? args)
    220             (lte_? (length args) 2)))))) input
    221 
    222 -- Preserve the existing bounded annotated-head path. Plain heads now retain
    223 -- located equations; annotated definitions cannot merge with those groups.
    224 sourceProgramAnnotated? input = (lazyList (_ : false)
    225   (token rest : let kind = sourceTokenKind token in (lazyBool (_ : true)
    226     (_ : lazyBool (_ : lazyList (_ : false)
    227         (next unused : equal? (sourceTokenKind next) sourceTokenAt) rest)
    228       (_ : lazyBool (_ : false) (_ : sourceProgramAnnotated? rest)
    229         (equal? kind sourceTokenNewline))
    230       (equal? kind sourceTokenAssign)) (equal? kind sourceTokenAt))) input)
    231 sourceProgramParsePlainBinding input = (lazyList
    232   (_ : sourceGateAtomError input)
    233   (token rest : sourceEquationBinding
    234     (sourceProgramDefinitionValue (sourcePositionColumn (sourceTokenStart token))) input) input)
    235 sourceProgramParseDefinition input =
    236   lazyBool
    237     (_ : lazyBool (_ : sourceProgramParseAnnotatedBinding input)
    238       (_ : sourceProgramParsePlainBinding input) (sourceProgramAnnotated? input))
    239     (_ : parserReplyFail
    240       (parserDiagnostic 2 sourceTokenAssign t t t) input false false)
    241     (sourceProgramDefinitionHead? input)
    242 
    243 sourceProgramParseTokens =
    244   parserThen sourceProgramSkipNewlines
    245     (parserBind
    246       (parserMany
    247         (parserBefore sourceProgramParseDefinition sourceProgramSkipNewlines))
    248       (definitions : parserBind
    249         (input : lazyResult
    250           (diagnostic rest : parserReplyFail diagnostic input false false)
    251           (groups unused : parserReplyOk groups input false false)
    252           (sourceEquationGroups definitions))
    253         (groups : parserBind
    254           (parserOptional
    255             (parserBefore sourceGateExpr sourceProgramSkipNewlines))
    256           (final : parserMap (_ : pair groups final) sourceGateEof))))
    257 
    258 parseGateProgram = parserWithLexer lexGateSource sourceProgramParseTokens
    259