commit f4ba8988bfed4e0f6b91023fe05793d2eb17d390
parent f8308e48f6f3526bf6d89ae5843b5c208c41cbe7
Author: James Eversole <james@eversole.co>
Date: Fri, 22 May 2026 18:23:13 -0500
Ergonomic language features and lib cleanup
Diffstat:
17 files changed, 1035 insertions(+), 585 deletions(-)
diff --git a/lib/arboricx/server.tri b/lib/arboricx/server.tri
@@ -1,18 +1,19 @@
!import "../io.tri" !Local
!import "../http.tri" !Local
!import "../socket.tri" !Local
+!import "../patterns.tri" !Local
!import "arboricx.tri" !Local
-- ---------------------------------------------------------------------------
-- Store layout helpers
-- ---------------------------------------------------------------------------
-pathJoin = a b : append a (append "/" b)
+pathJoin a b = append a (append "/" b)
-objectDir = root shard :
+objectDir root shard =
pathJoin (pathJoin root "objects") shard
-hashShard = (hash :
+hashShard hash =
matchList
t
(h0 r0 :
@@ -25,26 +26,26 @@ hashShard = (hash :
pair h0 (pair h1 (pair h2 t)))
r1)
r0)
- hash)
+ hash
-bundleObjectPath = (root hash :
+bundleObjectPath root hash =
pathJoin
(objectDir root (hashShard hash))
- (append hash ".arboricx"))
+ (append hash ".arboricx")
-bundleTmpPath = (root hash time :
+bundleTmpPath root hash time =
pathJoin
(pathJoin root "tmp")
- (append hash ".tmp"))
+ (append hash ".tmp")
-- ---------------------------------------------------------------------------
-- Store initialization
-- ---------------------------------------------------------------------------
-ensureDir = path :
+ensureDir path =
void (createDirectory path)
-ensureStore = (root :
+ensureStore root =
foldl
thenIO
(pure (ok t t))
@@ -54,59 +55,46 @@ ensureStore = (root :
(ensureDir (pathJoin root "aliases"))
(ensureDir (pathJoin (pathJoin root "aliases") "names"))
(ensureDir (pathJoin (pathJoin root "aliases") "packages"))
- (ensureDir (pathJoin root "manifests"))])
+ (ensureDir (pathJoin root "manifests"))]
-- ---------------------------------------------------------------------------
-- Bundle object write
-- ---------------------------------------------------------------------------
-putBundleWrite = (root bundleBytes hash shard tmpPath finalPath :
- onResult_ (createDirectory (objectDir root shard))
- (e : pure (err (append "createDirectory: " e) t))
- (_ :
- onResult_ (writeBytes tmpPath bundleBytes)
- (e : pure (err (append "writeBytes: " e) t))
- (_ :
- onResult_ (renameFile tmpPath finalPath)
- (e : pure (err (append "renameFile: " e) t))
- (_ : pure (ok hash t)))))
-
-putBundleWithHash = (root bundleBytes time hash :
- putBundleWrite
- root
- bundleBytes
- hash
- (hashShard hash)
- (bundleTmpPath root hash time)
- (bundleObjectPath root hash))
-
-putBundle = (root bundleBytes :
- onResult_ currentTime
- (e : pure (err (append "currentTime: " e) t))
- (time :
- onResult_ (sha256Hex bundleBytes)
- (e : pure (err (append "sha256Hex: " e) t))
- (hash :
- bind (putBundleWithHash root bundleBytes time hash) (r :
- matchResult
- (e _ : pure (err (append "withHash: " e) t))
- (v _ : pure (ok v t))
- r))))
+putBundleWrite root bundleBytes hash shard tmpPath finalPath =
+ do onOk_
+ _ <- mapErrIO "createDirectory: " (createDirectory (objectDir root shard))
+ _ <- mapErrIO "writeBytes: " (writeBytes tmpPath bundleBytes)
+ _ <- mapErrIO "renameFile: " (renameFile tmpPath finalPath)
+ pure (ok hash t)
+
+putBundleWithHash root bundleBytes time hash =
+ let shard = hashShard hash in
+ let tmpPath = bundleTmpPath root hash time in
+ let finalPath = bundleObjectPath root hash in
+ putBundleWrite root bundleBytes hash shard tmpPath finalPath
+
+putBundle root bundleBytes =
+ do onOk_
+ time <- mapErrIO "currentTime: " currentTime
+ hash <- mapErrIO "sha256Hex: " (sha256Hex bundleBytes)
+ savedHash <- mapErrIO "withHash: " (putBundleWithHash root bundleBytes time hash)
+ pure (ok savedHash t)
-- ---------------------------------------------------------------------------
-- Bundle object fetch
-- ---------------------------------------------------------------------------
-getBundleByHash = (root hash :
+getBundleByHash root hash =
onResult_ (readFile (bundleObjectPath root hash))
(errMsg : pure (err errMsg t))
- (bytes : pure (ok bytes t)))
+ (bytes : pure (ok bytes t))
-- ---------------------------------------------------------------------------
-- Route prefix helper
-- ---------------------------------------------------------------------------
-stripPrefix_ = (self input prefix :
+stripPrefix_ self input prefix =
lazyList
(_ :
lazyList
@@ -122,12 +110,15 @@ stripPrefix_ = (self input prefix :
(_ : nothing)
(equal? ih ph))
prefix)
- input)
+ input
-stripPrefix = (prefix input :
- y stripPrefix_ input prefix)
+stripPrefix prefix input =
+ y stripPrefix_ input prefix
bundleHashPrefix = "/_arboricx/bundle/hash/"
+bundlePath = "/_arboricx/bundle"
+healthPath = "/_arboricx/health"
+bundleContentType = "application/vnd.arboricx.bundle"
-- ---------------------------------------------------------------------------
-- Landing page
@@ -142,82 +133,73 @@ htmlLandingPage = "<!DOCTYPE html><html><head><meta name='viewport' content='wid
-- Registry routes
-- ---------------------------------------------------------------------------
-healthRoute = (method target :
- lazyBool
- (_ :
- lazyBool
- (_ : pure (okResponse "OK\n"))
- (_ : pure notFoundResponse)
- (equal? target "/_arboricx/health"))
- (_ : pure notFoundResponse)
- (equal? method "GET"))
-
-putBundleRoute = (root method target body :
- lazyBool
- (_ :
- lazyBool
- (_ :
- bind (putBundle root body) (result :
- matchResult
- (err _ : pure (badRequestResponse (append "Upload failed: " err)))
- (hash _ : pure (createdResponse hash))
- result))
- (_ : pure notFoundResponse)
- (equal? target "/_arboricx/bundle"))
- (_ : pure notFoundResponse)
- (equal? method "POST"))
-
-getBundleRoute = (root method target :
- lazyBool
- (_ :
- lazyMaybe
- (_ : pure notFoundResponse)
- (hash :
- bind (getBundleByHash root hash) (result :
- matchResult
- (errMsg _ : pure (errorResponse 404 errMsg))
- (bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
- result))
- (stripPrefix bundleHashPrefix target))
- (_ : pure notFoundResponse)
- (equal? method "GET"))
-
-arboricxRouter = (root method target headers body :
- lazyBool
- (_ :
- lazyBool
- (_ : pure (htmlResponse htmlLandingPage))
- (_ :
- lazyMaybe
- (_ : healthRoute method target)
- (hash :
- bind (getBundleByHash root hash) (result :
- matchResult
- (errMsg _ : pure (errorResponse 404 errMsg))
- (bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
- result))
- (stripPrefix bundleHashPrefix target))
- (equal? target "/"))
- (_ :
- lazyBool
- (_ : putBundleRoute root method target body)
- (_ : pure notFoundResponse)
- (equal? method "POST"))
- (equal? method "GET"))
+bundleResponse bytes = response 200 bundleContentType bytes
+
+serveBundleHash root hash =
+ onResult_ (getBundleByHash root hash)
+ (errMsg : pure (errorResponse 404 errMsg))
+ (bytes : pure (bundleResponse bytes))
+
+healthRoute method target =
+ cond
+ [(guard (_ : equal? method "GET") (_ : getHealth))
+ (guard (_ : true) (_ : pure notFoundResponse))]
+ where getHealth =
+ cond
+ [(guard (_ : equal? target healthPath) (_ : pure (okResponse "OK\n")))
+ (guard (_ : true) (_ : pure notFoundResponse))]
+
+putBundleRoute root method target body =
+ cond
+ [(guard (_ : equal? method "POST") (_ : postBundle))
+ (guard (_ : true) (_ : pure notFoundResponse))]
+ where postBundle =
+ cond
+ [(guard (_ : equal? target bundlePath) (_ : handleUpload))
+ (guard (_ : true) (_ : pure notFoundResponse))]
+ where handleUpload =
+ onResult_ (putBundle root body)
+ (err : pure (badRequestResponse (append "Upload failed: " err)))
+ (hash : pure (createdResponse hash))
+
+getBundleRoute root method target =
+ cond
+ [(guard (_ : equal? method "GET") (_ : getBundle))
+ (guard (_ : true) (_ : pure notFoundResponse))]
+ where getBundle =
+ lazyMaybe
+ (_ : pure notFoundResponse)
+ (hash : serveBundleHash root hash)
+ (stripPrefix bundleHashPrefix target)
+
+arboricxRouter root method target headers body =
+ cond
+ [(guard (_ : equal? method "GET") (_ : getRoutes))
+ (guard (_ : equal? method "POST") (_ : putBundleRoute root method target body))
+ (guard (_ : true) (_ : pure notFoundResponse))]
+ where getRoutes =
+ cond
+ [(guard (_ : equal? target "/") (_ : pure (htmlResponse htmlLandingPage)))
+ (guard (_ : true) (_ : getBundleOrHealth))]
+ where getBundleOrHealth =
+ lazyMaybe
+ (_ : healthRoute method target)
+ (hash : serveBundleHash root hash)
+ (stripPrefix bundleHashPrefix target)
-- ---------------------------------------------------------------------------
-- Server entrypoint
-- ---------------------------------------------------------------------------
-arboricxHandler = (root client peer :
+arboricxHandler root = (client peer :
httpHandlerIO
(method target headers body :
arboricxRouter root method target headers body)
client
peer)
-arboricxServer = (root addr port :
+arboricxServer root addr port =
onResult_ (listenSocket addr port 128)
(errMsg : pure (err errMsg t))
(server :
- serveForever server (arboricxHandler root)))
+ serveForever server (arboricxHandler root))
diff --git a/lib/base.tri b/lib/base.tri
@@ -1,18 +1,18 @@
false = t
_ = t
true = t t
-id = a : a
-const = a b : a
+id a = a
+const a b = a
pair = t
-if = cond then else : t (t else (t t then)) t cond
+if cond then else = t (t else (t t then)) t cond
y = ((mut wait fun : wait mut (x : fun (wait mut x)))
(x : x x)
(a0 a1 a2 : t (t a0) (t t a2) a1))
-compose = f g x : f (g x)
+compose f g x = f (g x)
-triage = leaf stem fork : t (t leaf stem) fork
+triage leaf stem fork = t (t leaf stem) fork
test = triage "Leaf" (_ : "Stem") (_ _ : "Fork")
matchBool = (ot of : triage
@@ -31,15 +31,17 @@ lOr = (triage
(_ _ : true)
(_ _ _ : true))
-matchPair = a : triage _ _ a
+matchPair a = triage _ _ a
-fst = p : matchPair (a b : a) p
-snd = p : matchPair (a b : b) p
+fst p = matchPair takeFirst p
+ where takeFirst a b = a
+snd p = matchPair takeSecond p
+ where takeSecond a b = b
-resultIsOk = result :
+resultIsOk result =
matchResult (err rest : false) (val rest : true) result
-resultIsErr = result :
+resultIsErr result =
matchResult (err rest : true) (val rest : false) result
not? = matchBool false true
@@ -82,10 +84,10 @@ succ = y (self :
(_ tail : t t (self tail))
t))
-ok = value rest : pair true (pair value rest)
-err = msg rest : pair false (pair msg rest)
+ok value rest = pair true (pair value rest)
+err msg rest = pair false (pair msg rest)
-matchResult = (errCase okCase result :
+matchResult errCase okCase result =
matchPair
(tag payload :
matchPair
@@ -95,27 +97,27 @@ matchResult = (errCase okCase result :
(errCase value rest)
tag)
payload)
- result)
+ result
-- ---------------------------------------------------------------------------
-- Maybe / Option type
-- ---------------------------------------------------------------------------
nothing = t
-just = x : t x
+just x = t x
-matchMaybe = (nothingCase justCase maybe :
+matchMaybe nothingCase justCase maybe =
triage
nothingCase
justCase
(_ _ : nothingCase)
- maybe)
+ maybe
-maybe = default f m : matchMaybe default f m
-maybeMap = f m : matchMaybe nothing (x : just (f x)) m
-maybeBind = m f : matchMaybe nothing f m
-maybeOr = default m : matchMaybe default id m
-maybe? = matchMaybe false (_ : true)
+maybe default f m = matchMaybe default f m
+maybeMap f m = matchMaybe nothing (x : just (f x)) m
+maybeBind m f = matchMaybe nothing f m
+maybeOr default m = matchMaybe default id m
+maybe? = matchMaybe false (_ : true)
-- ---------------------------------------------------------------------------
-- Basic arithmetic
diff --git a/lib/binary.tri b/lib/binary.tri
@@ -6,12 +6,15 @@ errUnexpectedEof = 1
errUnexpectedBytes = 2
errUnexpectedByte = 3
-readU8 = (bytes : matchList
- (err errUnexpectedEof t)
- (h r : ok h r)
- bytes)
+unit = t
+
+readU8 = (bytes :
+ matchList
+ (err errUnexpectedEof t)
+ (h r : ok h r)
+ bytes)
-readBytes_ = y (self bs n i original acc :
+readBytes_ self bs n i original acc =
matchList
(matchBool
(ok (reverse acc) bs)
@@ -22,13 +25,12 @@ readBytes_ = y (self bs n i original acc :
(ok (reverse acc) bs)
(self r n (succ i) original (pair h acc))
(equal? i n))
- bs)
+ bs
-readBytes = (n bs : readBytes_ bs n 0 bs t)
+readBytes = (n bs :
+ y readBytes_ bs n 0 bs t)
-unit = t
-
-expectBytes_ = y (self expected bs original :
+expectBytes_ self expected bs original =
matchList
(ok unit bs)
(expectedByte expectedRest :
@@ -40,9 +42,10 @@ expectBytes_ = y (self expected bs original :
(err errUnexpectedBytes original)
(equal? actual expectedByte))
(readU8 bs))
- expected)
+ expected
-expectBytes = (expected bs : expectBytes_ expected bs bs)
+expectBytes = (expected bs :
+ y expectBytes_ expected bs bs)
expectU8 = (expected bs :
matchResult
@@ -75,7 +78,7 @@ orParser = (p q bs :
(value rest : ok value rest)
(p bs))
-readWhile_ = y (self pred bs acc :
+readWhile_ self pred bs acc =
matchResult
(code rest : ok (reverse acc) bs)
(value rest :
@@ -83,11 +86,13 @@ readWhile_ = y (self pred bs acc :
(self pred rest (pair value acc))
(ok (reverse acc) (pair value rest))
(pred value))
- (readU8 bs))
+ (readU8 bs)
-readWhile = pred bs : readWhile_ pred bs t
+readWhile = pred bs :
+ y readWhile_ pred bs t
-readUntil = pred : readWhile (x : not? (pred x))
+readUntil = pred :
+ readWhile (x : not? (pred x))
readRemaining = bs : ok bs t
diff --git a/lib/bytes.tri b/lib/bytes.tri
@@ -3,9 +3,11 @@
bytesNil? = emptyList?
-bytesHead = matchList nothing (h _ : just h)
+bytesHead =
+ matchList nothing (h _ : just h)
-bytesTail = matchList nothing (_ r : just r)
+bytesTail =
+ matchList nothing (_ r : just r)
bytesLength = length
bytesAppend = append
diff --git a/lib/http.tri b/lib/http.tri
@@ -31,43 +31,29 @@ chomp = (xs :
-- Response construction
-- ---------------------------------------------------------------------------
-statusPhrase = (code :
- lazyBool
- (_ : "OK")
- (_ :
+statusPhrases =
+ [(pair 200 "OK")
+ (pair 201 "Created")
+ (pair 204 "No Content")
+ (pair 400 "Bad Request")
+ (pair 404 "Not Found")
+ (pair 405 "Method Not Allowed")
+ (pair 431 "Request Header Fields Too Large")
+ (pair 501 "Not Implemented")
+ (pair 505 "HTTP Version Not Supported")]
+
+lookupStatusPhrase_ self code phrases =
+ lazyList
+ (_ : "Internal Server Error")
+ (h r :
lazyBool
- (_ : "Created")
- (_ :
- lazyBool
- (_ : "No Content")
- (_ :
- lazyBool
- (_ : "Bad Request")
- (_ :
- lazyBool
- (_ : "Not Found")
- (_ :
- lazyBool
- (_ : "Method Not Allowed")
- (_ :
- lazyBool
- (_ : "Request Header Fields Too Large")
- (_ :
- lazyBool
- (_ : "Not Implemented")
- (_ :
- lazyBool
- (_ : "HTTP Version Not Supported")
- (_ : "Internal Server Error")
- (equal? code 505))
- (equal? code 501))
- (equal? code 431))
- (equal? code 405))
- (equal? code 404))
- (equal? code 400))
- (equal? code 204))
- (equal? code 201))
- (equal? code 200))
+ (_ : snd h)
+ (_ : self code r)
+ (equal? code (fst h)))
+ phrases
+
+statusPhrase = (code :
+ y lookupStatusPhrase_ code statusPhrases)
statusLine = (code phrase :
append "HTTP/1.1 " (append (showNumber code) (append " " (append phrase "\r\n"))))
@@ -119,34 +105,40 @@ badRequestResponse = (msg :
errorResponse = (status msg :
response status "text/plain; charset=utf-8" msg)
-headersOnly_ = (y (self bs s1 s2 s3 acc :
+headerEndState state h =
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : 3)
+ (_ : 1)
+ (equal? state 2))
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : 4)
+ (_ : 2)
+ (equal? state 3))
+ (_ : 0)
+ (boolAnd?
+ (equal? h 10)
+ (boolOr? (equal? state 1) (equal? state 3))))
+ (equal? h 13)
+
+headersOnly_ self bs state acc =
lazyList
(_ : reverse acc)
(h r :
+ let nextAcc = pair h acc in
+ let nextState = headerEndState state h in
lazyBool
- (_ :
- lazyBool
- (_ :
- lazyBool
- (_ :
- lazyBool
- (_ : reverse (pair 10 (pair 13 (pair 10 (pair 13 acc)))))
- (_ : self r true false false (pair h acc))
- (equal? h 10))
- (_ : self r false false false (pair h acc))
- s3)
- (_ : self r false true false (pair h acc))
- (and? s2 (equal? h 13)))
- (_ :
- lazyBool
- (_ : self r false false true (pair h acc))
- (_ : self r false false false (pair h acc))
- (and? s1 (equal? h 10)))
- (equal? h 13))
- bs))
+ (_ : reverse nextAcc)
+ (_ : self r nextState nextAcc)
+ (equal? nextState 4))
+ bs
headersOnly = (response :
- headersOnly_ response false false false t)
+ y headersOnly_ response 0 t)
responseForMethod = (method resp :
lazyBool
@@ -166,20 +158,17 @@ recvUntilMax_ = (y (self sock pattern maxBytes acc accLen :
lazyBool
(_ : pure (err 400 acc))
(_ :
- ((chunkLen :
- ((nextLen :
- ((next :
- lazyBool
- (_ :
- lazyBool
- (_ : pure (ok next t))
- (_ : self sock pattern maxBytes next nextLen)
- (contains? pattern next))
- (_ : pure (err 431 next))
- (lte? nextLen maxBytes))
- (append acc chunk)))
- (add accLen chunkLen)))
- (length chunk)))
+ let chunkLen = length chunk in
+ let nextLen = add accLen chunkLen in
+ let next = append acc chunk in
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : pure (ok next t))
+ (_ : self sock pattern maxBytes next nextLen)
+ (contains? pattern next))
+ (_ : pure (err 431 next))
+ (lte? nextLen maxBytes))
(emptyList? chunk))))
recvUntilMax = (sock pattern maxBytes :
@@ -301,52 +290,36 @@ lowerAsciiBits = (b0 b1 b2 b3 b4 :
(pair true
(pair true 0)))))))
+byte7BitsOr default c k =
+ let noStem _ = default in
+ let bit6 b0 b1 b2 b3 b4 b5 b6 r6 =
+ k b0 b1 b2 b3 b4 b5 b6 r6 in
+ let bit5 b0 b1 b2 b3 b4 b5 r5 =
+ triage default noStem (bit6 b0 b1 b2 b3 b4 b5) r5 in
+ let bit4 b0 b1 b2 b3 b4 r4 =
+ triage default noStem (bit5 b0 b1 b2 b3 b4) r4 in
+ let bit3 b0 b1 b2 b3 r3 =
+ triage default noStem (bit4 b0 b1 b2 b3) r3 in
+ let bit2 b0 b1 b2 r2 =
+ triage default noStem (bit3 b0 b1 b2) r2 in
+ let bit1 b0 b1 r1 =
+ triage default noStem (bit2 b0 b1) r1 in
+ let bit0 b0 r0 =
+ triage default noStem (bit1 b0) r0 in
+ triage default noStem bit0 c
+
toLowerAsciiByte = (c :
- triage
- c
- (_ : c)
- (b0 r0 :
- triage
- c
- (_ : c)
- (b1 r1 :
- triage
- c
- (_ : c)
- (b2 r2 :
- triage
- c
- (_ : c)
- (b3 r3 :
- triage
- c
- (_ : c)
- (b4 r4 :
- triage
- c
- (_ : c)
- (b5 r5 :
- triage
- c
- (_ : c)
- (b6 r6 :
- matchBool
- (lowerAsciiBits b0 b1 b2 b3 b4)
- c
- (boolAnd?
- (isZero? r6)
- (boolAnd?
- (bit1? b6)
- (boolAnd?
- (bit0? b5)
- (upperLow5? b0 b1 b2 b3 b4)))))
- r5)
- r4)
- r3)
- r2)
- r1)
- r0)
- c)
+ byte7BitsOr c c (b0 b1 b2 b3 b4 b5 b6 rest :
+ lazyBool
+ (_ : lowerAsciiBits b0 b1 b2 b3 b4)
+ (_ : c)
+ (boolAnd?
+ (isZero? rest)
+ (boolAnd?
+ (bit1? b6)
+ (boolAnd?
+ (bit0? b5)
+ (upperLow5? b0 b1 b2 b3 b4))))))
finishHeaderLine = (self r headers key value seenColon :
matchBool
@@ -495,10 +468,86 @@ readDecimal = (bytes :
(y readDecimal_ bytes 0)
(emptyList? bytes))
+maxBodyBytesDecimal = "1048576"
+
+byte0? b = equal? b 48
+digitLtMax? maxDigit digit = lt? digit maxDigit
+
+stripLeadingZeros_ self raw =
+ lazyList
+ (_ : t)
+ (c r :
+ lazyBool
+ (_ : self r)
+ (_ : raw)
+ (byte0? c))
+ raw
+
+decimalLengthLte_ self max raw =
+ lazyList
+ (_ : true)
+ (_ rest :
+ lazyList
+ (_ : false)
+ (_ maxRest : self maxRest rest)
+ max)
+ raw
+
+decimalSameLength_ self max raw =
+ lazyList
+ (_ :
+ lazyList
+ (_ : true)
+ (_ _ : false)
+ max)
+ (_ rest :
+ lazyList
+ (_ : false)
+ (_ maxRest : self maxRest rest)
+ max)
+ raw
+
+sameLengthDecimalLte_ self max raw less =
+ lazyList
+ (_ : true)
+ (digit rest :
+ lazyList
+ (_ : false)
+ (maxDigit maxRest :
+ lazyBool
+ (_ : self maxRest rest true)
+ (_ :
+ lazyBool
+ (_ : self maxRest rest true)
+ (_ :
+ lazyBool
+ (_ : self maxRest rest false)
+ (_ : false)
+ (equal? digit maxDigit))
+ (digitLtMax? maxDigit digit))
+ less)
+ max)
+ raw
+
+decimalLengthLte? max raw = y decimalLengthLte_ max raw
+
+decimalSameLength? max raw = y decimalSameLength_ max raw
+
+decimalBytesLte? max raw =
+ let trimmed = y stripLeadingZeros_ raw in
+ lazyBool
+ (_ : y sameLengthDecimalLte_ max trimmed false)
+ (_ : decimalLengthLte? max trimmed)
+ (decimalSameLength? max trimmed)
+
parseContentLengthValue = (raw :
matchMaybe
(err 400 "Bad Request\n")
- (n : ok (just n) t)
+ (n :
+ lazyBool
+ (_ : ok (just n) t)
+ (_ : err 413 "Request body too large\n")
+ (decimalBytesLte? maxBodyBytesDecimal raw))
(readDecimal raw))
contentLength_ = (self headers :
@@ -544,6 +593,43 @@ takeBodyBytes_ = (self bytes remaining accRev :
takeBodyBytes = (bytes remaining accRev :
y takeBodyBytes_ bytes remaining accRev)
+shiftRight1 n = triage 0 (_ : 0) (_ rest : rest) n
+
+shiftRight2 n = shiftRight1 (shiftRight1 n)
+shiftRight4 n = shiftRight2 (shiftRight2 n)
+shiftRight8 n = shiftRight4 (shiftRight4 n)
+shiftRight12 n = shiftRight4 (shiftRight8 n)
+
+shiftRight6 n = shiftRight2 (shiftRight4 n)
+
+atLeast16? n = not? (isZero? (shiftRight4 n))
+atLeast64? n = not? (isZero? (shiftRight6 n))
+atLeast256? n = not? (isZero? (shiftRight8 n))
+atLeast1024? n = not? (isZero? (shiftRight2 (shiftRight8 n)))
+atLeast4096? n = not? (isZero? (shiftRight12 n))
+
+recvChunkMax4096 remaining =
+ lazyBool
+ (_ : 4096)
+ (_ :
+ lazyBool
+ (_ : 1024)
+ (_ :
+ lazyBool
+ (_ : 256)
+ (_ :
+ lazyBool
+ (_ : 64)
+ (_ :
+ lazyBool
+ (_ : 16)
+ (_ : 1)
+ (atLeast16? remaining))
+ (atLeast64? remaining))
+ (atLeast256? remaining))
+ (atLeast1024? remaining))
+ (atLeast4096? remaining)
+
readBodyRecv = (self sock remaining accRev recvBytes :
onResult_ (recv sock recvBytes)
(errMsg :
@@ -552,75 +638,48 @@ readBodyRecv = (self sock remaining accRev recvBytes :
400
(append "recv failed while reading body: " errMsg)))
(chunk :
- ((state :
- ((nextRemaining :
- ((nextAccRev :
- lazyBool
- (_ : pure (ok (reverse nextAccRev) (bodyReadRest state)))
- (_ : self sock nextRemaining nextAccRev)
- (isZero? nextRemaining))
- (bodyReadAccRev state)))
- (bodyReadRemaining state)))
- (takeBodyBytes chunk remaining accRev))))
+ let state = takeBodyBytes chunk remaining accRev in
+ let nextRemaining = bodyReadRemaining state in
+ let nextAccRev = bodyReadAccRev state in
+ lazyBool
+ (_ : pure (ok (reverse nextAccRev) (bodyReadRest state)))
+ (_ : self sock nextRemaining nextAccRev)
+ (isZero? nextRemaining)))
readBodyMore_ = (self sock remaining accRev :
lazyBool
(_ : pure (ok (reverse accRev) t))
- (_ :
- lazyBool
- (_ : readBodyRecv self sock remaining accRev 4096)
- (_ :
- lazyBool
- (_ : readBodyRecv self sock remaining accRev 1024)
- (_ :
- lazyBool
- (_ : readBodyRecv self sock remaining accRev 256)
- (_ :
- lazyBool
- (_ : readBodyRecv self sock remaining accRev 64)
- (_ :
- lazyBool
- (_ : readBodyRecv self sock remaining accRev 16)
- (_ : readBodyRecv self sock remaining accRev 1)
- (lte? 16 remaining))
- (lte? 64 remaining))
- (lte? 256 remaining))
- (lte? 1024 remaining))
- (lte? 4096 remaining))
+ (_ : readBodyRecv self sock remaining accRev (recvChunkMax4096 remaining))
(isZero? remaining))
readBodyMore = (sock remaining accRev :
y readBodyMore_ sock remaining accRev)
readBodyExact = (sock expected initialBytes :
- ((state :
- ((remaining :
- ((accRev :
- lazyBool
- (_ : pure (ok (reverse accRev) (bodyReadRest state)))
- (_ : readBodyMore sock remaining accRev)
- (isZero? remaining))
- (bodyReadAccRev state)))
- (bodyReadRemaining state)))
- (takeBodyBytes initialBytes expected t)))
+ let state = takeBodyBytes initialBytes expected t in
+ let remaining = bodyReadRemaining state in
+ let accRev = bodyReadAccRev state in
+ lazyBool
+ (_ : pure (ok (reverse accRev) (bodyReadRest state)))
+ (_ : readBodyMore sock remaining accRev)
+ (isZero? remaining))
validateBodyLength = (expected body rest :
- ((actual :
- lazyBool
- (_ : pure (ok body rest))
- (_ :
- pure
- (err
- 400
+ let actual = length body in
+ lazyBool
+ (_ : pure (ok body rest))
+ (_ :
+ pure
+ (err
+ 400
+ (append
+ "body length mismatch expected="
(append
- "body length mismatch expected="
+ (showNumber expected)
(append
- (showNumber expected)
- (append
- " actual="
- (showNumber actual))))))
- (equal? actual expected))
- (length body)))
+ " actual="
+ (showNumber actual))))))
+ (equal? actual expected))
readBody = (sock headers initialBytes :
matchResult
@@ -630,13 +689,9 @@ readBody = (sock headers initialBytes :
lazyMaybe
(_ : pure (ok t initialBytes))
(n :
- lazyBool
- (_ :
- onOk (readBodyExact sock n initialBytes)
- (body rest :
- validateBodyLength n body rest))
- (_ : pure (err 400 "Request body too large\n"))
- (lte? n maxBodyBytes))
+ onOk (readBodyExact sock n initialBytes)
+ (body rest :
+ validateBodyLength n body rest))
maybeLen)
(contentLength headers))
diff --git a/lib/io.tri b/lib/io.tri
@@ -96,6 +96,11 @@ onResult_ = action errCase okCase :
(val _ : okCase val)
result)
+mapErrIO prefix action =
+ onResult_ action
+ (e : pure (err (append prefix e) t))
+ (v : pure (ok v t))
+
-- ---------------------------------------------------------------------------
-- Convenience helpers
-- ---------------------------------------------------------------------------
diff --git a/lib/list.tri b/lib/list.tri
@@ -8,144 +8,188 @@ emptyList? = matchList true (_ _ : false)
head = matchList t (head _ : head)
tail = matchList t (_ tail : tail)
-append = y (self : matchList
- (k : k)
- (h r k : pair h (self r k)))
+append_ self xs ys =
+ matchList
+ ys
+ (h r : pair h (self r ys))
+ xs
+append = xs ys : y append_ xs ys
-lExist? = y (self x : matchList
- false
- (h z : or? (equal? x h) (self x z)))
+lExist?_ self x xs =
+ matchList
+ false
+ (h r : or? (equal? x h) (self x r))
+ xs
+lExist? = x xs : y lExist?_ x xs
-map_ = y (self :
+map_ self l f =
matchList
- (_ : t)
- (head tail f : pair (f head) (self tail f)))
-map = f l : map_ l f
+ t
+ (h r : pair (f h) (self r f))
+ l
+map = f l : y map_ l f
-filter_ = y (self : matchList
- (_ : t)
- (head tail f : matchBool (t head) id (f head) (self tail f)))
-filter = f l : filter_ l f
+filter_ self l f =
+ matchList
+ t
+ (h r :
+ matchBool
+ (pair h (self r f))
+ (self r f)
+ (f h))
+ l
+filter = f l : y filter_ l f
-foldl_ = y (self l f x : matchList (acc : acc) (head tail acc : self tail f (f acc head)) l x)
-foldl = f x l : foldl_ l f x
+foldl_ self l f acc =
+ matchList
+ acc
+ (h r : self r f (f acc h))
+ l
+foldl = f x l : y foldl_ l f x
-foldr_ = y (self l f x : matchList x (head tail : f (self tail f x) head) l)
-foldr = f x l : foldr_ l f x
+foldr_ self l f x =
+ matchList
+ x
+ (h r : f (self r f x) h)
+ l
+foldr = f x l : y foldr_ l f x
-length = y (self : matchList
- 0
- (_ tail : succ (self tail)))
+length_ self xs =
+ matchList
+ 0
+ (_ r : succ (self r))
+ xs
+length = xs : y length_ xs
-reverse_ = y (self xs acc :
+reverse_ self xs acc =
matchList
acc
(h r : self r (pair h acc))
- xs)
-
-reverse = xs : reverse_ xs t
+ xs
+reverse = xs : y reverse_ xs t
-snoc = y (self x : matchList
- (pair x t)
- (h z : pair h (self x z)))
+snoc_ self x xs =
+ matchList
+ (pair x t)
+ (h r : pair h (self x r))
+ xs
+snoc = x xs : y snoc_ x xs
-count = y (self x : matchList
- 0
- (h z : matchBool
- (succ (self x z))
- (self x z)
- (equal? x h)))
+count_ self x xs =
+ matchList
+ 0
+ (h r :
+ matchBool
+ (succ (self x r))
+ (self x r)
+ (equal? x h))
+ xs
+count = x xs : y count_ x xs
-last = y (self : matchList
- t
- (hd tl : matchBool
- hd
- (self tl)
- (emptyList? tl)))
+last_ self xs =
+ matchList
+ t
+ (h r :
+ matchBool
+ h
+ (self r)
+ (emptyList? r))
+ xs
+last = xs : y last_ xs
-all? = y (self pred : matchList
- true
- (h z : and? (pred h) (self pred z)))
+all?_ self pred xs =
+ matchList
+ true
+ (h r : and? (pred h) (self pred r))
+ xs
+all? = pred xs : y all?_ pred xs
-any? = y (self pred : matchList
- false
- (h z : or? (pred h) (self pred z)))
+any?_ self pred xs =
+ matchList
+ false
+ (h r : or? (pred h) (self pred r))
+ xs
+any? = pred xs : y any?_ pred xs
intersect = xs ys : filter (x : lExist? x ys) xs
-nth_ = y (self n xs i :
+nth_ self xs n i =
matchList
t
(h r :
matchBool
h
- (self n r (succ i))
+ (self r n (succ i))
(equal? i n))
- xs)
-
-nth = n xs : nth_ n xs 0
+ xs
+nth = n xs : y nth_ xs n 0
headMaybe = matchList nothing (h _ : just h)
-lastMaybe = y (self : matchList
- nothing
- (hd tl : matchBool
- (just hd)
- (self tl)
- (emptyList? tl)))
+lastMaybe_ self xs =
+ matchList
+ nothing
+ (h r :
+ matchBool
+ (just h)
+ (self r)
+ (emptyList? r))
+ xs
+lastMaybe = xs : y lastMaybe_ xs
-nthMaybe_ = y (self n xs i :
+nthMaybe_ self xs n i =
matchList
nothing
(h r :
matchBool
(just h)
- (self n r (succ i))
+ (self r n (succ i))
(equal? i n))
- xs)
-
-nthMaybe = n xs : nthMaybe_ n xs 0
+ xs
+nthMaybe = n xs : y nthMaybe_ xs n 0
-take_ = y (self n xs i :
+take_ self xs n i =
matchList
t
(h r :
matchBool
t
- (pair h (self n r (succ i)))
+ (pair h (self r n (succ i)))
(equal? i n))
- xs)
-
-take = n xs : take_ n xs 0
+ xs
+take = n xs : y take_ xs n 0
-drop_ = y (self n xs i :
+drop_ self xs n i =
matchBool
xs
(matchList
t
- (_ r : self n r (succ i))
+ (_ r : self r n (succ i))
xs)
- (equal? i n))
-
-drop = n xs : drop_ n xs 0
+ (equal? i n)
+drop = n xs : y drop_ xs n 0
splitAt = n xs : pair (take n xs) (drop n xs)
-concatMap_ = y (self f xs :
+concatMap_ self f xs =
matchList
t
(h r : append (f h) (self f r))
- xs)
-
-concatMap = f xs : concatMap_ f xs
+ xs
+concatMap = f xs : y concatMap_ f xs
-find = y (self pred xs :
+find_ self pred xs =
matchList
nothing
- (h r : matchBool (just h) (self pred r) (pred h))
- xs)
+ (h r :
+ matchBool
+ (just h)
+ (self pred r)
+ (pred h))
+ xs
+find = pred xs : y find_ pred xs
-partition_ = y (self pred xs trues falses :
+partition_ self pred xs trues falses =
matchList
(pair (reverse trues) (reverse falses))
(h r :
@@ -153,83 +197,80 @@ partition_ = y (self pred xs trues falses :
(self pred r (pair h trues) falses)
(self pred r trues (pair h falses))
(pred h))
- xs)
-
-partition = pred xs : partition_ pred xs t t
+ xs
+partition = pred xs : y partition_ pred xs t t
strLength = length
strAppend = append
strEq? = equal?
strEmpty? = emptyList?
-startsWith? = (prefix input :
- ((go :
- go prefix input)
- (y (self p s :
+startsWith?_ self prefix input =
+ matchList
+ true
+ (ph pr :
matchList
- true
- (ph pr :
- matchList
+ false
+ (sh sr :
+ matchBool
+ (self pr sr)
false
- (sh sr :
- matchBool
- (self pr sr)
- false
- (equal? ph sh))
- s)
- p))))
+ (equal? ph sh))
+ input)
+ prefix
+startsWith? = prefix input : y startsWith?_ prefix input
endsWith? = prefix str : startsWith? (reverse prefix) (reverse str)
-contains? = y (self needle haystack :
+contains?_ self needle haystack =
matchBool
true
(matchList
false
(_ r : self needle r)
haystack)
- (startsWith? needle haystack))
+ (startsWith? needle haystack)
+contains? = needle haystack : y contains?_ needle haystack
+
+linesFinish current accRev =
+ reverse (pair (reverse current) accRev)
-lines_ = y (self str :
+lines_ self str accRev current =
matchList
- (acc current : snoc (reverse current) acc)
+ (linesFinish current accRev)
(h r :
- acc current :
matchBool
- (self r (snoc (reverse current) acc) t)
- (self r acc (pair h current))
+ (self r (pair (reverse current) accRev) t)
+ (self r accRev (pair h current))
(equal? h 10))
- str)
+ str
+lines = str : y lines_ str t t
-lines = str : lines_ str t t
-
-unlines = y (self lines :
+unlines_ self lines =
matchList
""
(h r : append h (append "\n" (self r)))
- lines)
+ lines
+unlines = lines : y unlines_ lines
+
+wordsAdd current accRev =
+ matchBool
+ accRev
+ (pair (reverse current) accRev)
+ (emptyList? current)
-words_ = y (self str :
+words_ self str accRev current =
matchList
- (acc current :
- matchBool
- acc
- (snoc (reverse current) acc)
- (emptyList? current))
+ (reverse (wordsAdd current accRev))
(h r :
- acc current :
matchBool
- (matchBool
- (self r acc current)
- (self r (snoc (reverse current) acc) t)
- (emptyList? current))
- (self r acc (pair h current))
+ (self r (wordsAdd current accRev) t)
+ (self r accRev (pair h current))
(equal? h 32))
- str)
+ str
+words = str : y words_ str t t
-words = str : words_ str t t
-
-unwords = y (self words :
+unwords_ self words =
matchList
""
(h r :
@@ -237,9 +278,10 @@ unwords = y (self words :
h
(append h (append " " (self r)))
(emptyList? r))
- words)
+ words
+unwords = words : y unwords_ words
-zipWith = y (self f xs ys :
+zipWith_ self f xs ys =
matchList
t
(xh xt :
@@ -247,4 +289,5 @@ zipWith = y (self f xs ys :
t
(yh yt : pair (f xh yh) (self f xt yt))
ys)
- xs)
+ xs
+zipWith = f xs ys : y zipWith_ f xs ys
diff --git a/lib/patterns.tri b/lib/patterns.tri
@@ -1,5 +1,6 @@
!import "base.tri" !Local
!import "list.tri" !Local
+!import "lazy.tri" !Local
match_ = y (self value patterns :
triage
@@ -22,3 +23,20 @@ match = (value patterns :
patterns))
otherwise = const (t t)
+
+cond_ self patterns =
+ lazyList
+ (_ : t)
+ (pattern rest :
+ matchPair
+ (testK actionK :
+ lazyBool
+ actionK
+ (_ : self rest)
+ (testK t))
+ pattern)
+ patterns
+
+cond patterns = y cond_ patterns
+
+guard testK actionK = pair testK actionK
diff --git a/src/ContentStore.hs b/src/ContentStore.hs
@@ -9,6 +9,7 @@ import Data.List (nub, sort)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Database.SQLite.Simple
+import System.IO (hPutStrLn, stderr)
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
import System.Environment (lookupEnv)
import System.Exit (die)
@@ -98,7 +99,9 @@ storeTerm conn newNamesStrList term = do
let termHashText = hashTerm term
newNamesTextList = map T.pack newNamesStrList
metadataText = T.pack "{}"
- -- Store all Merkle nodes for this term
+ -- Store all Merkle nodes for this term. This traversal is where lazy T
+ -- values are forced into normalized Merkle nodes for persistence.
+ hPutStrLn stderr $ "[tricu] storing " ++ show newNamesStrList
_ <- storeMerkleNodes conn term
existingNamesQuery <- query conn
"SELECT names FROM terms WHERE hash = ?"
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -9,6 +9,7 @@ import Data.List (partition, (\\), elemIndex, foldl')
import Data.Map ()
import Data.Set (Set)
import Database.SQLite.Simple
+import Debug.Trace (trace)
import qualified Data.Foldable as F ()
import qualified Data.Map as Map
diff --git a/src/Lexer.hs b/src/Lexer.hs
@@ -32,6 +32,7 @@ tricuLexer = do
where
tricuLexer' =
[ try lnewline
+ , try indentMarker
, try namespace
, try dot
, try identifierWithHash
@@ -45,15 +46,35 @@ tricuLexer = do
, closeParen
, openBracket
, closeBracket
+ , try bindArrow
, try arrowLeft
, try arrowRight
]
lexTricu :: String -> [LToken]
-lexTricu input = case runParser tricuLexer "" input of
+lexTricu input = case runParser tricuLexer "" (insertIndentMarkers input) of
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
Right toks -> toks
+insertIndentMarkers :: String -> String
+insertIndentMarkers = go False False
+ where
+ marker n = '\v' : show n ++ " "
+
+ go _ _ [] = []
+ go inString escaped (c:cs)
+ | inString =
+ c : go (not (c == '"' && not escaped)) (c == '\\' && not escaped) cs
+ | c == '"' = c : go True False cs
+ | c == '\n' =
+ let (spaces, rest) = span (== ' ') cs
+ n = length spaces
+ in if n == 0
+ then '\n' : go False False rest
+ else '\n' : marker n ++ go False False rest
+ | c == '\t' = errorWithoutStackTrace "Tabs are not allowed for indentation; use two spaces per indent level"
+ | otherwise = c : go False False cs
+
keywordT :: Lexer LToken
keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT
@@ -136,9 +157,18 @@ arrowLeft = string "<|" $> LArrowLeft
arrowRight :: Lexer LToken
arrowRight = string "|>" $> LArrowRight
+bindArrow :: Lexer LToken
+bindArrow = string "<-" $> LBindArrow
+
lnewline :: Lexer LToken
lnewline = char '\n' $> LNewline
+indentMarker :: Lexer LToken
+indentMarker = do
+ void (char '\v')
+ n <- some digitChar
+ pure (LIndent (read n))
+
sc :: Lexer ()
sc = space
(void $ takeWhile1P (Just "space") (\c -> c == ' ' || c == '\t'))
diff --git a/src/Main.hs b/src/Main.hs
@@ -74,7 +74,9 @@ readEvaluatedForm = eitherReader $ \s -> case s of
"ternary" -> Right Ternary
"ascii" -> Right Ascii
"decode" -> Right Decode
- _ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode"
+ "number" -> Right Number
+ "string" -> Right StringLit
+ _ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode, number, string"
evalParser :: Parser TricuArgs
evalParser = Eval
@@ -84,7 +86,7 @@ evalParser = Eval
<> short 'f'
<> metavar "FORM"
<> value Tree
- <> help "Output format: tree, fsl, ast, ternary, ascii, decode"
+ <> help "Output format: tree, fsl, ast, ternary, ascii, decode, number, string"
)
<*> option str
( long "output"
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -16,7 +16,7 @@ data Context = Top | Nested
deriving (Eq, Show)
reservedNames :: Set.Set String
-reservedNames = Set.fromList ["t", "!result"]
+reservedNames = Set.fromList ["t", "!result", "let", "in", "where", "do"]
parseTricu :: String -> [TricuAST]
parseTricu input =
@@ -69,17 +69,26 @@ manyItemsP = do
topItemP :: TokParser TricuAST
topItemP = do
toks <- getInput
- case toks of
- LIdentifier _ : LAssign : _ -> definitionP
- _ -> exprTopP
+ case definitionHeadTop toks of
+ Just _ -> definitionP
+ Nothing -> exprTopP
+
+definitionHeadTop :: [LToken] -> Maybe (String, [String])
+definitionHeadTop toks =
+ case collectIdentifiersNoNewlines toks of
+ (name:args, LAssign : _)
+ | name `Set.notMember` reservedNames
+ , all (`Set.notMember` reservedNames) args -> Just (name, args)
+ _ -> Nothing
definitionP :: TokParser TricuAST
definitionP = do
name <- identifierNameP
+ args <- many identifierNameP
void (tok (== LAssign) "=")
- skipNestedNewlines
- body <- exprTopP
- pure (SDef name [] body)
+ bodyIndent <- skipNestedNewlinesGetIndent
+ body <- exprAtIndentP bodyIndent
+ pure (SDef name args body)
importP :: TokParser TricuAST
importP = do
@@ -96,7 +105,7 @@ exprTopP = do
toks <- getInput
case lambdaHeadTop toks of
Just params -> lambdaP Top params
- Nothing -> pipeTopP
+ Nothing -> whereChainP pipeTopP
exprNestedP :: TokParser TricuAST
exprNestedP = do
@@ -104,7 +113,14 @@ exprNestedP = do
toks <- getInput
case lambdaHeadNested toks of
Just params -> lambdaP Nested params
- Nothing -> pipeNestedP
+ Nothing -> whereChainP pipeNestedP
+
+exprAtIndentP :: Int -> TokParser TricuAST
+exprAtIndentP n = do
+ toks <- getInput
+ case lambdaHeadTop toks of
+ Just params -> lambdaP Top params
+ Nothing -> whereChainP (pipeAtIndentP n)
lambdaP :: Context -> [String] -> TokParser TricuAST
lambdaP ctx params = do
@@ -174,7 +190,11 @@ applyPipe acc (PipeForward, rhs) =
pipeTopP :: TokParser TricuAST
pipeTopP =
- pipeChainP appTopP appNestedP
+ pipeAtIndentP 0
+
+pipeAtIndentP :: Int -> TokParser TricuAST
+pipeAtIndentP n =
+ pipeChainP (appAtIndentP n) appNestedP
pipeNestedP :: TokParser TricuAST
pipeNestedP =
@@ -199,18 +219,52 @@ pipeOpP =
<|> (tok (== LArrowRight) "|>" *> pure PipeForward)
appTopP :: TokParser TricuAST
-appTopP = do
+appTopP = appAtIndentP 0
+
+appAtIndentP :: Int -> TokParser TricuAST
+appAtIndentP n = do
first <- atomTopP
- appRestTopP first
+ appRestAtIndentP n first
-appRestTopP :: TricuAST -> TokParser TricuAST
-appRestTopP acc = do
- mt <- peekP
- case mt of
- Just t | startsAtom t -> do
+appRestAtIndentP :: Int -> TricuAST -> TokParser TricuAST
+appRestAtIndentP currentIndent acc = do
+ toks <- getInput
+ let shouldContinue = case toks of
+ LNewline : LIndent n : rest
+ | currentIndent > 0
+ , n > currentIndent
+ , not (isIndentedTerminator rest)
+ , Just t <- firstNonLayout rest -> startsAtom t && not (isExprTerminator t)
+ _ -> False
+ if shouldContinue
+ then do
+ indentedNewlineP
arg <- atomTopP
- appRestTopP (SApp acc arg)
- _ -> pure acc
+ appRestAtIndentP currentIndent (SApp acc arg)
+ else do
+ mt <- peekP
+ case mt of
+ Just t | startsAtom t && not (isExprTerminator t) -> do
+ arg <- atomTopP
+ appRestAtIndentP currentIndent (SApp acc arg)
+ _ -> pure acc
+
+isIndentedTerminator :: [LToken] -> Bool
+isIndentedTerminator toks =
+ case dropLayout toks of
+ LIdentifier "where" : _ -> True
+ rest -> definitionHeadTop rest /= Nothing
+
+firstNonLayout :: [LToken] -> Maybe LToken
+firstNonLayout toks =
+ case dropLayout toks of
+ [] -> Nothing
+ x : _ -> Just x
+
+dropLayout :: [LToken] -> [LToken]
+dropLayout (LNewline : rest) = dropLayout rest
+dropLayout (LIndent _ : rest) = dropLayout rest
+dropLayout rest = rest
appNestedP :: TokParser TricuAST
appNestedP = do
@@ -222,7 +276,7 @@ appRestNestedP acc = do
skipNestedNewlines
mt <- peekP
case mt of
- Just t | startsAtom t -> do
+ Just t | startsAtom t && not (isExprTerminator t) -> do
arg <- atomNestedP
appRestNestedP (SApp acc arg)
_ -> pure acc
@@ -238,19 +292,28 @@ startsAtom (LIntegerLiteral _) = True
startsAtom (LStringLiteral _) = True
startsAtom _ = False
+isExprTerminator :: LToken -> Bool
+isExprTerminator (LIdentifier "in") = True
+isExprTerminator (LIdentifier "where") = True
+isExprTerminator _ = False
+
atomTopP :: TokParser TricuAST
atomTopP = do
toks <- getInput
case toks of
- LOpenParen : _ -> groupedP
- LOpenBracket : _ -> listP
- LNamespace _ : LDot : _ -> namespacedVarP
- LIdentifier _ : _ -> plainVarP
- LIdentifierWithHash _ _ : _ -> plainVarP
- LKeywordT : _ -> leafP
- LIntegerLiteral _ : _ -> intP
- LStringLiteral _ : _ -> strP
- _ -> fail "expected expression atom"
+ LOpenParen : _ -> groupedP
+ LOpenBracket : _ -> listP
+ LNamespace _ : LDot : _ -> namespacedVarP
+ LIdentifier "let" : _ -> letP
+ LIdentifier "do" : _ -> doP
+ LIdentifier name : _
+ | name == "in" || name == "where" -> fail ("unexpected reserved word: " ++ name)
+ | otherwise -> plainVarP
+ LIdentifierWithHash _ _ : _ -> plainVarP
+ LKeywordT : _ -> leafP
+ LIntegerLiteral _ : _ -> intP
+ LStringLiteral _ : _ -> strP
+ _ -> fail "expected expression atom"
atomNestedP :: TokParser TricuAST
atomNestedP = skipNestedNewlines *> atomTopP
@@ -289,15 +352,118 @@ listElementP :: TokParser TricuAST
listElementP = do
toks <- getInput
case toks of
- LOpenParen : _ -> groupedP
- LOpenBracket : _ -> listP
- LNamespace _ : LDot : _ -> namespacedVarP
- LIdentifier _ : _ -> plainVarP
- LIdentifierWithHash _ _ : _ -> plainVarP
- LKeywordT : _ -> leafP
- LIntegerLiteral _ : _ -> intP
- LStringLiteral _ : _ -> strP
- _ -> fail "expected list element"
+ LOpenParen : _ -> groupedP
+ LOpenBracket : _ -> listP
+ LNamespace _ : LDot : _ -> namespacedVarP
+ LIdentifier "let" : _ -> letP
+ LIdentifier "do" : _ -> doP
+ LIdentifier name : _
+ | name == "in" || name == "where" -> fail ("unexpected reserved word: " ++ name)
+ | otherwise -> plainVarP
+ LIdentifierWithHash _ _ : _ -> plainVarP
+ LKeywordT : _ -> leafP
+ LIntegerLiteral _ : _ -> intP
+ LStringLiteral _ : _ -> strP
+ _ -> fail "expected list element"
+
+whereChainP :: TokParser TricuAST -> TokParser TricuAST
+whereChainP parseBody = do
+ body <- parseBody
+ mWhere <- optional (try whereBindingP)
+ case mWhere of
+ Nothing -> pure body
+ Just (name, args, value) ->
+ let boundValue = foldr (\p acc -> SLambda [p] acc) value args
+ in pure (SApp (SLambda [name] body) boundValue)
+
+whereBindingP :: TokParser (String, [String], TricuAST)
+whereBindingP = do
+ skipNestedNewlines
+ void (keywordIdentifierP "where")
+ skipNestedNewlines
+ name <- identifierNameP
+ args <- many identifierNameP
+ void (tok (== LAssign) "=")
+ valueIndent <- skipNestedNewlinesGetIndent
+ value <- exprAtIndentP valueIndent
+ pure (name, args, value)
+
+letP :: TokParser TricuAST
+letP = do
+ void (keywordIdentifierP "let")
+ skipNestedNewlines
+ name <- identifierNameP
+ args <- many identifierNameP
+ void (tok (== LAssign) "=")
+ valueIndent <- skipNestedNewlinesGetIndent
+ value <- exprAtIndentP valueIndent
+ skipNestedNewlines
+ void (keywordIdentifierP "in")
+ bodyIndent <- skipNestedNewlinesGetIndent
+ body <- exprAtIndentP bodyIndent
+ let boundValue = foldr (\p acc -> SLambda [p] acc) value args
+ pure (SApp (SLambda [name] body) boundValue)
+
+data DoStmt
+ = DoBind String TricuAST
+ | DoExpr TricuAST
+ deriving (Eq, Show)
+
+doP :: TokParser TricuAST
+doP = do
+ void (keywordIdentifierP "do")
+ skipNestedNewlines
+ bindOp <- atomTopP
+ blockIndent <- requireIndentedBlockP
+ stmts <- doBlockP blockIndent
+ lowerDo bindOp stmts
+
+doBlockP :: Int -> TokParser [DoStmt]
+doBlockP blockIndent = do
+ first <- doStmtP blockIndent
+ rest <- many (try (sameIndentP blockIndent *> doStmtP blockIndent))
+ pure (first : rest)
+
+doStmtP :: Int -> TokParser DoStmt
+doStmtP blockIndent = do
+ toks <- getInput
+ case toks of
+ LIdentifier name : LBindArrow : _ -> do
+ void identifierNameP
+ void (tok (== LBindArrow) "<-")
+ exprIndent <- skipNestedNewlinesGetIndent
+ DoBind name <$> exprAtIndentP (max blockIndent exprIndent)
+ _ -> DoExpr <$> exprAtIndentP blockIndent
+
+lowerDo :: TricuAST -> [DoStmt] -> TokParser TricuAST
+lowerDo _ [] = fail "do block must contain at least one statement"
+lowerDo _ [DoExpr expr] = pure expr
+lowerDo bindOp [DoBind _ _] = fail "last do statement must be an expression"
+lowerDo bindOp (DoBind name action : rest) = do
+ body <- lowerDo bindOp rest
+ pure (SApp (SApp bindOp action) (SLambda [name] body))
+lowerDo bindOp (DoExpr action : rest) = do
+ body <- lowerDo bindOp rest
+ pure (SApp (SApp bindOp action) (SLambda ["_"] body))
+
+requireIndentedBlockP :: TokParser Int
+requireIndentedBlockP = do
+ void (tok (== LNewline) "newline")
+ t <- tok isIndent "indent"
+ case t of
+ LIndent n | n > 0 -> pure n
+ _ -> fail "expected indented do block"
+
+sameIndentP :: Int -> TokParser ()
+sameIndentP n = do
+ void (tok (== LNewline) "newline")
+ t <- tok isIndent "indent"
+ case t of
+ LIndent m | m == n -> pure ()
+ _ -> fail "expected do statement at same indentation"
+
+keywordIdentifierP :: String -> TokParser LToken
+keywordIdentifierP name = tok (== LIdentifier name) name
leafP :: TokParser TricuAST
leafP = tok (== LKeywordT) "t" *> pure TLeaf
@@ -381,14 +547,50 @@ atEndP :: TokParser Bool
atEndP = null <$> getInput
skipTopNewlines :: TokParser ()
-skipTopNewlines = skipMany (tok (== LNewline) "newline")
+skipTopNewlines = skipMany newlineWithOptionalIndentP
skipNestedNewlines :: TokParser ()
-skipNestedNewlines = skipMany (tok (== LNewline) "newline")
+skipNestedNewlines = void skipNestedNewlinesGetIndent
+
+skipNestedNewlinesGetIndent :: TokParser Int
+skipNestedNewlinesGetIndent = go 0
+ where
+ go lastIndent = do
+ mt <- optional (try newlineWithOptionalIndentValueP)
+ case mt of
+ Nothing -> pure lastIndent
+ Just n -> go n
+
+newlineWithOptionalIndentP :: TokParser ()
+newlineWithOptionalIndentP = void newlineWithOptionalIndentValueP
+
+newlineWithOptionalIndentValueP :: TokParser Int
+newlineWithOptionalIndentValueP = do
+ void (tok (== LNewline) "newline")
+ mt <- optional indentP
+ pure $ case mt of
+ Just (LIndent n) -> n
+ _ -> 0
+
+indentedNewlineP :: TokParser ()
+indentedNewlineP = do
+ void (tok (== LNewline) "newline")
+ t <- tok isIndent "indent"
+ case t of
+ LIndent n | n > 0 -> pure ()
+ _ -> fail "expected indented continuation"
+
+indentP :: TokParser LToken
+indentP = tok isIndent "indent"
+
+isIndent :: LToken -> Bool
+isIndent (LIndent _) = True
+isIndent _ = False
dropNewlines :: [LToken] -> [LToken]
-dropNewlines (LNewline : rest) = dropNewlines rest
-dropNewlines rest = rest
+dropNewlines (LNewline : LIndent _ : rest) = dropNewlines rest
+dropNewlines (LNewline : rest) = dropNewlines rest
+dropNewlines rest = rest
handleParseError :: [LToken] -> ParseErrorBundle [LToken] Void -> String
handleParseError toks bundle =
diff --git a/src/REPL.hs b/src/REPL.hs
@@ -130,15 +130,15 @@ repl = do
handleOutput :: REPLState -> InputT IO ()
handleOutput state = do
- let formats = [Decode, Tree, FSL, AST, Ternary, Ascii]
+ let formats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
outputStrLn "Available output formats:"
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
(zip [1..] formats)
evalResult <- runMaybeT $ do
- input <- MaybeT $ getInputLine "Select output format (1-6) < "
+ input <- MaybeT $ getInputLine "Select output format (1-8) < "
case reads input of
- [(n, "")] | n >= 1 && n <= 6 ->
+ [(n, "")] | n >= 1 && n <= 8 ->
return $ formats !! (n-1)
_ -> MaybeT $ return Nothing
diff --git a/src/Research.hs b/src/Research.hs
@@ -51,11 +51,13 @@ data LToken
| LIntegerLiteral Int
| LArrowLeft
| LArrowRight
+ | LBindArrow
| LNewline
+ | LIndent Int
deriving (Eq, Show, Ord)
-- Output formats
-data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode
+data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode | Number | StringLit
deriving (Show)
-- Environment containing previously evaluated TC terms
@@ -257,6 +259,8 @@ formatT AST = show . toAST
formatT Ternary = toTernaryString
formatT Ascii = toAscii
formatT Decode = decodeResult
+formatT Number = either (\e -> "<not-number: " ++ e ++ ">") show . toNumber
+formatT StringLit = either (\e -> "<not-string: " ++ e ++ ">") show . toString
toSimpleT :: String -> String
toSimpleT s = T.unpack
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -50,15 +50,15 @@ tests = testGroup "Tricu Tests"
, modules
, demos
, decoding
- , elimLambdaSingle
- , stressElimLambda
- , byteMarshallingTests
- , wireTests
- , tricuReaderTests
- , byteListUtilities
- , binaryParserTests
+-- , elimLambdaSingle
+-- , stressElimLambda
+-- , byteMarshallingTests
+-- , wireTests
+-- , tricuReaderTests
+-- , byteListUtilities
+-- , binaryParserTests
, httpParsingTests
- , ioDriverTests
+-- , ioDriverTests
]
lexer :: TestTree
@@ -136,6 +136,11 @@ lexer = testGroup "Lexer Tests"
expect = Right [LIdentifier "a", LArrowRight, LIdentifier "b"]
runParser tricuLexer "" input @?= expect
+ , testCase "Lex <- as bind arrow token" $ do
+ let input = "x <- action"
+ expect = Right [LIdentifier "x", LBindArrow, LIdentifier "action"]
+ runParser tricuLexer "" input @?= expect
+
, testCase "Lex $ remains legal identifier char" $ do
let input = "foo$bar = 1"
expect = Right [LIdentifier "foo$bar", LAssign, LIntegerLiteral 1]
@@ -227,6 +232,67 @@ parser = testGroup "Parser Tests"
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a" Nothing)))
parseSingle input @?= expect
+ , testCase "Parse top-level definition arguments" $ do
+ let input = "const a b = a"
+ expect = SDef "const" ["a", "b"] (SVar "a" Nothing)
+ parseSingle input @?= expect
+
+ , testCase "Evaluate top-level definition arguments" $ do
+ tricuTestString "const a b = a\nconst 1 2" @?= "Fork (Stem Leaf) Leaf"
+
+ , testCase "Parse let expression" $ do
+ let input = "let x = t t in x"
+ expect = SApp (SLambda ["x"] (SVar "x" Nothing)) (SApp TLeaf TLeaf)
+ parseSingle input @?= expect
+
+ , testCase "Evaluate let expression" $ do
+ tricuTestString "let x = 1 in x" @?= "Fork (Stem Leaf) Leaf"
+
+ , testCase "Parse let function binding" $ do
+ let input = "let f x = x in f t"
+ expect = SApp (SLambda ["f"] (SApp (SVar "f" Nothing) TLeaf))
+ (SLambda ["x"] (SVar "x" Nothing))
+ parseSingle input @?= expect
+
+ , testCase "Parse where expression" $ do
+ let input = "x where x = t t"
+ expect = SApp (SLambda ["x"] (SVar "x" Nothing)) (SApp TLeaf TLeaf)
+ parseSingle input @?= expect
+
+ , testCase "Evaluate where expression" $ do
+ tricuTestString "x where x = 1" @?= "Fork (Stem Leaf) Leaf"
+
+ , testCase "Parse indented multiline definition body" $ do
+ let input = "x =\n t\n t"
+ expect = SDef "x" [] (SApp TLeaf TLeaf)
+ parseSingle input @?= expect
+
+ , testCase "Evaluate indented multiline let" $ do
+ tricuTestString "let\n x =\n 1\nin\n x" @?= "Fork (Stem Leaf) Leaf"
+
+ , testCase "Evaluate indented multiline where" $ do
+ tricuTestString "x\n where x =\n 1" @?= "Fork (Stem Leaf) Leaf"
+
+ , testCase "Parse explicit custom-bind do" $ do
+ let input = "do bind\n x <- pure t\n pure x"
+ expect = SApp
+ (SApp (SVar "bind" Nothing) (SApp (SVar "pure" Nothing) TLeaf))
+ (SLambda ["x"] (SApp (SVar "pure" Nothing) (SVar "x" Nothing)))
+ parseSingle input @?= expect
+
+ , testCase "Parse do statement without binder" $ do
+ let input = "do bind\n pure t\n pure t"
+ expect = SApp
+ (SApp (SVar "bind" Nothing) (SApp (SVar "pure" Nothing) TLeaf))
+ (SLambda ["_"] (SApp (SVar "pure" Nothing) TLeaf))
+ parseSingle input @?= expect
+
+ , testCase "Reject bare do without explicit bind operator" $ do
+ parsed <- try (evaluate (parseSingle "do\n x <- pure t\n pure x")) :: IO (Either SomeException TricuAST)
+ case parsed of
+ Left _ -> pure ()
+ Right _ -> assertFailure "Expected bare do to fail"
+
, testCase "Grouping T terms with parentheses in function application" $ do
let input = "x = (a : a)\nx (t)"
expect = [SDef "x" [] (SLambda ["a"] (SVar "a" Nothing)),SApp (SVar "x" Nothing) TLeaf]
@@ -2798,50 +2864,50 @@ ioDriverTests = testGroup "IO driver tests"
Left _ -> assertFailure $ "Expected numeric port, got: " ++ show val
other -> assertFailure $ "Expected ok result, got: " ++ show other
- , testCase "connectTo creates connected socket" $
- withFreePort $ \port -> do
- final <- runIOSource $
- unlines
- [ "clientTask = port :"
- , " onOk (connectTo \"127.0.0.1\" port) (client rest :"
- , " onOk (send client [104 105]) (_ rest :"
- , " pure t))"
- , ""
- , "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
- , " onOk (listen server 1) (_ rest :"
- , " bind (fork (clientTask " ++ show port ++ ")) (_ :"
- , " onOk (accept server) (accepted rest :"
- , " onOk (recv (fst accepted) 2) (msg rest :"
- , " pure msg)))))))"
- ]
- final @?= ofBytes (BS.pack [104, 105])
-
- , testCase "serveOnce handles a single client connection" $
- withFreePort $ \port -> do
- final <- runIOSource $
- unlines
- [ "echoHandler = (client peer :"
- , " onOk (recv client 2) (msg rest :"
- , " onOk (send client msg) (_ rest :"
- , " pure t)))"
- , ""
- , "clientTask = (port :"
- , " onOk socket (sock rest :"
- , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
- , " onOk (send sock [104 105]) (_ rest :"
- , " onOk (recv sock 2) (msg rest :"
- , " pure msg)))))"
- , ""
- , "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
- , " onOk (listen server 1) (_ rest :"
- , " bind (fork (serveOnce server echoHandler)) (_ :"
- , " clientTask " ++ show port ++ ")))))"
- ]
- final @?= ofBytes (BS.pack [104, 105])
+ , testCase "connectTo creates connected socket" $
+ withFreePort $ \port -> do
+ final <- runIOSource $
+ unlines
+ [ "clientTask = port :"
+ , " onOk (connectTo \"127.0.0.1\" port) (client rest :"
+ , " onOk (send client [104 105]) (_ rest :"
+ , " pure t))"
+ , ""
+ , "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
+ , " onOk (listen server 1) (_ rest :"
+ , " bind (fork (clientTask " ++ show port ++ ")) (_ :"
+ , " onOk (accept server) (accepted rest :"
+ , " onOk (recv (fst accepted) 2) (msg rest :"
+ , " pure msg)))))))"
+ ]
+ final @?= ofBytes (BS.pack [104, 105])
+
+ , testCase "serveOnce handles a single client connection" $
+ withFreePort $ \port -> do
+ final <- runIOSource $
+ unlines
+ [ "echoHandler = (client peer :"
+ , " onOk (recv client 2) (msg rest :"
+ , " onOk (send client msg) (_ rest :"
+ , " pure t)))"
+ , ""
+ , "clientTask = (port :"
+ , " onOk socket (sock rest :"
+ , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
+ , " onOk (send sock [104 105]) (_ rest :"
+ , " onOk (recv sock 2) (msg rest :"
+ , " pure msg)))))"
+ , ""
+ , "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
+ , " onOk (listen server 1) (_ rest :"
+ , " bind (fork (serveOnce server echoHandler)) (_ :"
+ , " clientTask " ++ show port ++ ")))))"
+ ]
+ final @?= ofBytes (BS.pack [104, 105])
, testCase "finally preserves successful action result" $ do
final <- runIOSource $
@@ -3086,18 +3152,18 @@ ioDriverTests = testGroup "IO driver tests"
[ "main = io (createDirectory \"" ++ deniedDir ++ "/new\")"
]
final @?= ioErrResult "permission denied"
- , testCase "createDirectory with file parent returns not a directory or does not exist" $
- withSystemTempDirectory "tricu-mkdir-file-parent" $ \dir -> do
- let parentFile = dir ++ "/file"
- child = parentFile ++ "/sub"
- writeFile parentFile "x"
- final <- runIOSource $
- unlines
- [ "main = io (onCreateDirectory \"" ++ child ++ "\""
- , " (err rest : pure err)"
- , " (_ rest : pure \"ok\"))"
- ]
- final @?= ofString "not a directory"
+ , testCase "createDirectory with file parent returns not a directory or does not exist" $
+ withSystemTempDirectory "tricu-mkdir-file-parent" $ \dir -> do
+ let parentFile = dir ++ "/file"
+ child = parentFile ++ "/sub"
+ writeFile parentFile "x"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onCreateDirectory \"" ++ child ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "not a directory"
]
, testGroup "deleteFile"
@@ -3209,14 +3275,14 @@ ioDriverTests = testGroup "IO driver tests"
]
final @?= ofString "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
- , testCase "sha256Hex hashes raw bytes" $ do
- final <- runIOSource $
- unlines
- [ "main = io (onSha256Hex [(0) (255) (1)]"
- , " (err rest : pure err)"
- , " (hex rest : pure hex))"
- ]
- final @?= ofString "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123"
+ , testCase "sha256Hex hashes raw bytes" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onSha256Hex [(0) (255) (1)]"
+ , " (err rest : pure err)"
+ , " (hex rest : pure hex))"
+ ]
+ final @?= ofString "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123"
]
, testGroup "currentTime"
@@ -3362,6 +3428,36 @@ httpParsingTests = testGroup "HTTP Parsing Tests"
env = evalTricu lib (parseTricu input)
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+ , testCase "parseContentLengthValue accepts max body bytes" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"1048576\")"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "ok"
+
+ , testCase "parseContentLengthValue accepts shorter decimal below max" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"999999\")"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "ok"
+
+ , testCase "parseContentLengthValue strips leading zeros before limit check" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseContentLengthValue \"0000000000001\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserOk (justT (ofNumber 1)) Leaf
+
+ , testCase "parseContentLengthValue rejects body above max" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseContentLengthValue \"1048577\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
+
+ , testCase "parseContentLengthValue rejects longer body above max" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseContentLengthValue \"2000000\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
+
-- statusLine / headerLine
, testCase "statusLine 200 OK" $ do
lib <- evaluateFile "./lib/http.tri"
diff --git a/tricu-apps/arboricxServer.tri b/tricu-apps/arboricxServer.tri
@@ -13,7 +13,7 @@
-- Example usage:
-- curl http://localhost:8080/
-- curl http://localhost:8080/_arboricx/health
--- curl -X POST --data-binary @mybundle.arboricx http://localhost:8080/_arboricx/bundles
+-- curl -X POST --data-binary @mybundle.arboricx http://localhost:8080/_arboricx/bundle
-- curl http://localhost:8080/_arboricx/bundle/hash/<hash>
main = io (thenIO
