tricu

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

registry-source.tri (3838B)

      1 !import prelude *
      2 !import parser as P
      3 !import consumers_source as C
      4 !import consumers_structural as SCP
      5 !import consumers_registry as R
      6 !export *
      7 -- Purposefully bounded SCP source frontend for the registry-route slice.
      8 -- Reuses the tricu-written tokenizer and parser protocol, not Haskell syntax.
      9 
     10 rsBindInput name pattern = P.parserMap (bindings : pair pattern bindings) (C.cBind name 0 t)
     11 rsMethod path = P.parserBind P.parserPeek (token :
     12   P.parserBind (C.cExpect C.cString) (target :
     13     P.parserOr
     14       (P.parserBind (C.cExpect C.cName) (name :
     15         matchResult
     16           (detail _ : P.parserFailure
     17             (P.parserDiagnostic 23 "proper literal prefix" detail
     18               (C.cStart token) t))
     19           (pattern _ : rsBindInput name
     20             (SCP.patFork (SCP.patLiteral "GET") pattern))
     21           (SCP.expandPrefix target 0)))
     22       (P.parserPure (pair (SCP.patFork (SCP.patLiteral "GET")
     23         (SCP.patLiteral target)) t))))
     24 rsReplyPattern success = P.parserBind (C.cExpect C.cName) (name :
     25   rsBindInput name (SCP.patFork (SCP.patLiteral success)
     26     (SCP.patFork (SCP.patCapture 0) SCP.patAny)))
     27 rsInput = P.parserBind (C.cExpect C.cName) (kind :
     28   lazyBool (_ : rsMethod kind)
     29     (_ : lazyBool (_ : rsReplyPattern true)
     30       (_ : lazyBool (_ : rsReplyPattern false)
     31         (_ : lazyBool (_ : P.parserPure (pair SCP.patAny t))
     32           (_ : P.parserFailure (C.cExpected "GET, Ok, Err or _" kind t))
     33           (equal? kind "_"))
     34         (equal? kind "Err"))
     35       (equal? kind "Ok"))
     36     (equal? kind "GET"))
     37 rsState bindings = P.parserBind (C.cExpect C.cName) (name :
     38   lazyBool
     39     (_ : P.parserPure (pair SCP.patAny bindings))
     40     (_ : P.parserMap (updated : pair
     41       (SCP.patCapture (length bindings)) updated)
     42       (C.cBind name (length bindings) bindings))
     43     (equal? name "_"))
     44 rsValue bindings = P.parserOr (P.parserMap SCP.outLiteral (C.cExpect C.cString)) (P.parserBind (C.cExpect C.cName) (name : C.cReference bindings name))
     45 rsResponse bindings = P.parserBind (C.cExpect C.cNumber) (status :
     46   P.parserBind (C.cExpect C.cString) (contentType :
     47     P.parserMap (body : R.reply status contentType body) (rsValue bindings)))
     48 rsRead programName bindings = P.parserThen (C.cWord "read") (P.parserBind (C.cExpect C.cName) (rootName :
     49       P.parserBind (C.cReference bindings rootName) (root :
     50         P.parserBind (C.cExpect C.cName) (hashName :
     51           P.parserBind (C.cReference bindings hashName) (hash :
     52             P.parserThen (C.cWord "resume")
     53               (P.parserThen (C.cWord programName)
     54                 (P.parserThen (C.cExpect C.cAt)
     55                   (P.parserBind (C.cExpect C.cName) (stateName :
     56                     P.parserMap (state : R.readBundle programName root hash state)
     57                       (C.cReference bindings stateName))))))))))
     58 rsOutput programName bindings = P.parserBind (C.cExpect C.cName) (kind :
     59   lazyBool (_ : rsResponse bindings)
     60     (_ : lazyBool (_ : rsRead programName bindings)
     61       (_ : P.parserFailure (C.cExpected "reply or await" kind t))
     62       (equal? kind "await"))
     63     (equal? kind "reply"))
     64 rsRule programName = P.parserBind rsInput (input :
     65   P.parserThen (C.cExpect C.cAt)
     66     (P.parserBind (rsState (snd input)) (state :
     67       P.parserThen (C.cExpect C.cArrow)
     68         (P.parserMap (body : SCP.makeRule (fst input) (fst state) body)
     69           (rsOutput programName (snd state))))))
     70 rsProgram = P.parserThen (C.cWord "consumer") (P.parserBind
     71   (C.cExpect C.cName) (name : P.parserBind (P.parserSome (rsRule name))
     72     (rules : P.parserMap (_ : pair name (SCP.makeConsumer t rules)) P.parserEof)))
     73 rsParse source = P.parserWithLexer C.lexConsumer rsProgram source
     74 compileRouteSource source = P.parserMatchReply (diagnostic rest consumed committed : err diagnostic t) (compiled rest consumed committed : ok compiled t) (rsParse source)