tricu

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

7a99fcc8da4c502ff67bc723b3ef317409a84f608c607cfa99331dd30245845a.tri (9814B)

      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 -- Bootstrap contract profile: definition heads only. Contract expressions
     44 -- are ordinary names or parenthesized applications, never static types.
     45 -- Keep the runtime Result checks (including short-circuit and value passing)
     46 -- identical to Frontend.ContractDesugar's supported base-library forms.
     47 sourceProgramContract =
     48   parserOr (sourceGateParseGroup (tokens : sourceGateExprWithLayout tokens sourceGateLayoutNested))
     49     (parserMap sourceAstName (sourceGateExpect sourceTokenName))
     50 
     51 -- Argument = pair (Maybe namedBinderToken) (Maybe contractExpression).
     52 sourceProgramArgNamed input =
     53   parserBind (sourceGateExpect sourceTokenName) (name :
     54     parserMap (contract : pair (just name) contract)
     55       (parserOptional (parserThen (sourceGateExpect sourceTokenAt)
     56         sourceProgramContract))) input
     57 
     58 sourceProgramArgPhantom =
     59   parserMap (contract : pair nothing (just contract))
     60     (parserThen (sourceGateExpect sourceTokenAt) sourceProgramContract)
     61 
     62 sourceProgramArgument = parserOr sourceProgramArgPhantom sourceProgramArgNamed
     63 
     64 sourceProgramSynthetic name node =
     65   sourceToken sourceTokenName name
     66     (sourceAstStart node) (sourceAstStart node)
     67 
     68 sourceProgramName name node = sourceAstName (sourceProgramSynthetic name node)
     69 sourceProgramApply2 function first second =
     70   sourceAstApply (sourceAstApply function first) second
     71 sourceProgramApply3 function first second third =
     72   sourceAstApply (sourceProgramApply2 function first second) third
     73 
     74 sourceProgramChecked contract value =
     75   sourceProgramApply2 (sourceProgramName "withContract" contract) contract value
     76 
     77 sourceProgramFailure msg =
     78   sourceProgramApply2
     79     (sourceProgramName "err" msg) msg
     80     (sourceAstLeaf (sourceProgramSynthetic "t" msg))
     81 
     82 sourceProgramOnFailure node =
     83   sourceAstLambda
     84     (sourceProgramSynthetic "msg" node)
     85     (sourceAstLambda (sourceProgramSynthetic "_" node)
     86       (sourceProgramFailure (sourceProgramName "msg" node)))
     87 
     88 -- Earlier failed arguments must still accept the remaining arguments before
     89 -- producing the error, just like the historical Haskell lowering.
     90 sourceProgramAbsorbFailure node =
     91   sourceAstLambda
     92     (sourceProgramSynthetic "msg" node)
     93     (sourceAstLambda (sourceProgramSynthetic "_" node)
     94       (sourceAstLambda (sourceProgramSynthetic "_" node)
     95         (sourceProgramFailure (sourceProgramName "msg" node))))
     96 
     97 sourceProgramReturn contract body =
     98   lazyMaybe
     99     (_ : body)
    100     (c : sourceProgramApply3
    101       (sourceProgramName "matchResult" c)
    102       (sourceProgramOnFailure c)
    103       (sourceAstLambda (sourceProgramSynthetic "r" c)
    104         (sourceAstLambda (sourceProgramSynthetic "_" c)
    105           (sourceProgramName "r" c)))
    106       (sourceProgramChecked c body))
    107     contract
    108 
    109 sourceProgramArgName arg index anchor =
    110   lazyMaybe
    111     (_ : sourceProgramSynthetic
    112       (if (isZero_? index) "x" (if (equal? index 1) "y" "z")) anchor)
    113     (token : token)
    114     (fst arg)
    115 
    116 sourceProgramRawApply args raw = (let rec
    117   walk args raw index =
    118     lazyList
    119       (_ : raw)
    120       (arg rest : walk rest
    121         (sourceAstApply raw
    122           (sourceAstName (sourceProgramArgName arg index raw)))
    123         (succ index))
    124       args
    125   in walk args raw 0)
    126 
    127 sourceProgramWrapArgs args body = (let rec
    128   walk args index =
    129     lazyList
    130       (_ : body)
    131       (arg rest :
    132         sourceAstLambda (sourceProgramArgName arg index body)
    133           (lazyMaybe
    134             (_ : walk rest (succ index))
    135             (c : sourceProgramApply3
    136               (sourceProgramName "matchResult" c)
    137               (lazyList
    138                 (_ : sourceProgramOnFailure c)
    139                 (other tail : sourceProgramAbsorbFailure c)
    140                 rest)
    141               (sourceAstLambda (sourceProgramArgName arg index body)
    142                 (sourceAstLambda (sourceProgramSynthetic "_" c)
    143                   (walk rest (succ index))))
    144               (sourceProgramChecked c
    145                 (sourceAstName (sourceProgramArgName arg index body))))
    146             (snd arg)))
    147       args
    148   in walk args 0)
    149 
    150 sourceProgramAnyContract? args =
    151   lazyList
    152     (_ : false)
    153     (arg rest : lazyMaybe
    154       (_ : sourceProgramAnyContract? rest)
    155       (contract : true)
    156       (snd arg))
    157     args
    158 
    159 sourceProgramAnyPhantom? args =
    160   lazyList
    161     (_ : false)
    162     (arg rest : lazyMaybe
    163       (_ : true)
    164       (name : sourceProgramAnyPhantom? rest)
    165       (fst arg))
    166     args
    167 
    168 sourceProgramAllPhantom? args =
    169   lazyList
    170     (_ : true)
    171     (arg rest : lazyMaybe
    172       (_ : sourceProgramAllPhantom? rest)
    173       (name : false)
    174       (fst arg))
    175     args
    176 
    177 sourceProgramPlainArgs args body =
    178   lazyList
    179     (_ : body)
    180     (arg rest : sourceAstLambda (sourceProgramArgName arg 0 body)
    181       (sourceProgramPlainArgs rest body))
    182     args
    183 
    184 sourceProgramLowerDefinition name args result body =
    185   lazyBool
    186     (_ : lazyBool
    187       (_ : sourceAstLocal
    188         (sourceToken sourceTokenName
    189           (append "_" (append (sourceTokenPayload name) "_raw"))
    190           (sourceTokenStart name) (sourceTokenEnd name))
    191         body
    192         (sourceProgramWrapArgs args
    193           (sourceProgramReturn result
    194             (sourceProgramRawApply args
    195               (sourceProgramName
    196                 (append "_" (append (sourceTokenPayload name) "_raw"))
    197                 body))))
    198         (sourceTokenStart name) (sourceAstEnd body))
    199       (_ : sourceProgramWrapArgs args (sourceProgramReturn result body))
    200       (sourceProgramAnyPhantom? args))
    201     (_ : sourceProgramPlainArgs args body)
    202     (or? (sourceProgramAnyContract? args)
    203       (lazyMaybe (_ : false) (contract : true) result))
    204 
    205 sourceProgramParseAnnotatedBinding input =
    206   parserBind (sourceGateExpect sourceTokenName) (name :
    207     parserBind (parserMany sourceProgramArgument) (args :
    208       (remaining : lazyBool
    209         (_ : parserThen (sourceGateExpect sourceTokenAssign)
    210           (parserBind (parserOptional
    211             (parserThen (sourceGateExpect sourceTokenAt)
    212               sourceProgramContract)) (result :
    213             parserMap (body : pair name
    214               (sourceProgramLowerDefinition name args result body))
    215               (sourceProgramDefinitionValue (sourcePositionColumn (sourceTokenStart name))))) remaining)
    216         (_ : parserReplyFail
    217           (parserDiagnostic 47 "supported contract head" t
    218             (sourceTokenStart name) t) remaining true false)
    219         (or? (not? (sourceProgramAnyPhantom? args))
    220           (and? (sourceProgramAllPhantom? args)
    221             (lte_? (length args) 2)))))) input
    222 
    223 -- Preserve the existing bounded annotated-head path. Plain heads now retain
    224 -- located equations; annotated definitions cannot merge with those groups.
    225 sourceProgramAnnotated? input = (lazyList (_ : false)
    226   (token rest : let kind = sourceTokenKind token in (lazyBool (_ : true)
    227     (_ : lazyBool (_ : lazyList (_ : false)
    228         (next unused : equal? (sourceTokenKind next) sourceTokenAt) rest)
    229       (_ : lazyBool (_ : false) (_ : sourceProgramAnnotated? rest)
    230         (equal? kind sourceTokenNewline))
    231       (equal? kind sourceTokenAssign)) (equal? kind sourceTokenAt))) input)
    232 sourceProgramParsePlainBinding input = (lazyList
    233   (_ : sourceGateAtomError input)
    234   (token rest : sourceEquationBinding
    235     (sourceProgramDefinitionValue (sourcePositionColumn (sourceTokenStart token))) input) input)
    236 sourceProgramParseDefinition input =
    237   lazyBool
    238     (_ : lazyBool (_ : sourceProgramParseAnnotatedBinding input)
    239       (_ : sourceProgramParsePlainBinding input) (sourceProgramAnnotated? input))
    240     (_ : parserReplyFail
    241       (parserDiagnostic 2 sourceTokenAssign t t t) input false false)
    242     (sourceProgramDefinitionHead? input)
    243 
    244 sourceProgramParseTokens =
    245   parserThen sourceProgramSkipNewlines
    246     (parserBind
    247       (parserMany
    248         (parserBefore sourceProgramParseDefinition sourceProgramSkipNewlines))
    249       (definitions : parserBind
    250         (input : lazyResult
    251           (diagnostic rest : parserReplyFail diagnostic input false false)
    252           (groups unused : parserReplyOk groups input false false)
    253           (sourceEquationGroups definitions))
    254         (groups : parserBind
    255           (parserOptional
    256             (parserBefore sourceGateExpr sourceProgramSkipNewlines))
    257           (final : parserMap (_ : pair groups final) sourceGateEof))))
    258 
    259 parseGateProgram = parserWithLexer lexGateSource sourceProgramParseTokens
    260