James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ergonomic language features and lib cleanup

Browse Source 
+ let bindings
+ where bindings
+ do notation

I explored enough of the alternative language design space and decided
that we should commit fully to Lambda style. That means no more highly
tacit/concatenative point-free/partial programs as default. We'll keep
taking advantage of those capabilities when it makes sense, but the
library will continue to see massive overhauls.
This commit is contained in:
James Eversole
2026-05-22 18:23:13 -05:00
parent 7cea3d1559
commit 2e2db07bd6
17 changed files with 1039 additions and 589 deletions
Download Patch File Download Diff File Expand all files Collapse all files

200
lib/arboricx/server.tri
View File

@@ -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)))))
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 :
putBundleWrite
root
bundleBytes
hash
(hashShard hash)
(bundleTmpPath root hash time)
(bundleObjectPath root hash))
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 :
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))))
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"))
bundleResponse bytes = response 200 bundleContentType bytes
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"))
serveBundleHash root hash =
onResult_ (getBundleByHash root hash)
(errMsg : pure (errorResponse 404 errMsg))
(bytes : pure (bundleResponse bytes))
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"))
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))]
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"))
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))

46
lib/base.tri
View File

@@ -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

37
lib/binary.tri
View File

@@ -6,12 +6,15 @@ errUnexpectedEof = 1
errUnexpectedBytes = 2
errUnexpectedByte = 3
readU8 = (bytes : matchList
(err errUnexpectedEof t)
(h r : ok h r)
bytes)
unit = t
readBytes_ = y (self bs n i original acc :
readU8 = (bytes :
matchList
(err errUnexpectedEof t)
(h r : ok h r)
bytes)
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

6
lib/bytes.tri
View File

@@ -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

417
lib/http.tri
View File

@@ -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 :
lazyList
(_ : reverse acc)
(h r :
headerEndState state h =
lazyBool
(_ :
lazyBool
(_ : 3)
(_ : 1)
(equal? state 2))
(_ :
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))
(_ : 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
(_ : 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))

5
lib/io.tri
View File

@@ -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
-- ---------------------------------------------------------------------------

315
lib/list.tri
View File

@@ -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)))
lExist? = y (self x : matchList
false
(h z : or? (equal? x h) (self x z)))
map_ = y (self :
append_ self xs ys =
matchList
(_ : t)
(head tail f : pair (f head) (self tail f)))
map = f l : map_ l f
ys
(h r : pair h (self r ys))
xs
append = xs ys : y append_ xs ys
filter_ = y (self : matchList
(_ : t)
(head tail f : matchBool (t head) id (f head) (self tail f)))
filter = f l : filter_ l f
lExist?_ self x xs =
matchList
false
(h r : or? (equal? x h) (self x r))
xs
lExist? = x xs : y lExist?_ x xs
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
map_ self l f =
matchList
t
(h r : pair (f h) (self r f))
l
map = f l : y map_ l f
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
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
length = y (self : matchList
0
(_ tail : succ (self tail)))
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
reverse_ = y (self xs acc :
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_ self xs =
matchList
0
(_ r : succ (self r))
xs
length = xs : y length_ xs
reverse_ self xs acc =
matchList
acc
(h r : self r (pair h acc))
xs)
xs
reverse = xs : y reverse_ xs t
reverse = xs : reverse_ xs t
snoc_ self x xs =
matchList
(pair x t)
(h r : pair h (self x r))
xs
snoc = x xs : y snoc_ x xs
snoc = y (self x : matchList
(pair x t)
(h z : pair h (self x z)))
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
count = y (self x : matchList
0
(h z : matchBool
(succ (self x z))
(self x z)
(equal? x h)))
last = y (self : matchList
t
(hd tl : matchBool
hd
(self tl)
(emptyList? tl)))
all? = y (self pred : matchList
true
(h z : and? (pred h) (self pred z)))
any? = y (self pred : matchList
false
(h z : or? (pred h) (self pred z)))
intersect = xs ys : filter (x : lExist? x ys) xs
nth_ = y (self n xs i :
last_ self xs =
matchList
t
(h r :
matchBool
h
(self n r (succ i))
(equal? i n))
xs)
(self r)
(emptyList? r))
xs
last = xs : y last_ xs
nth = n xs : nth_ n xs 0
all?_ self pred xs =
matchList
true
(h r : and? (pred h) (self pred r))
xs
all? = pred xs : y all?_ pred xs
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_ self xs n i =
matchList
t
(h r :
matchBool
h
(self r n (succ i))
(equal? i n))
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)))
nthMaybe_ = y (self n xs i :
lastMaybe_ self xs =
matchList
nothing
(h r :
matchBool
(just h)
(self n r (succ i))
(self r)
(emptyList? r))
xs
lastMaybe = xs : y lastMaybe_ xs
nthMaybe_ self xs n i =
matchList
nothing
(h r :
matchBool
(just h)
(self r n (succ i))
(equal? i n))
xs)
xs
nthMaybe = n xs : y nthMaybe_ xs n 0
nthMaybe = n xs : nthMaybe_ n xs 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)
xs
take = n xs : y take_ xs n 0
take = n xs : take_ n xs 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)
xs
concatMap = f xs : y concatMap_ f xs
concatMap = f xs : 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
lines_ = y (self str :
linesFinish current accRev =
reverse (pair (reverse current) accRev)
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
words_ = y (self str :
wordsAdd current accRev =
matchBool
accRev
(pair (reverse current) accRev)
(emptyList? current)
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

18
lib/patterns.tri
View File

@@ -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

5
src/ContentStore.hs
View File

@@ -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 = ?"

1
src/Eval.hs
View File

@@ -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

32
src/Lexer.hs
View File

@@ -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'))

6
src/Main.hs
View File

@@ -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"

288
src/Parser.hs
View File

@@ -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
first <- atomTopP
appRestTopP first
appTopP = appAtIndentP 0
appRestTopP :: TricuAST -> TokParser TricuAST
appRestTopP acc = do
mt <- peekP
case mt of
Just t | startsAtom t -> do
appAtIndentP :: Int -> TokParser TricuAST
appAtIndentP n = do
first <- atomTopP
appRestAtIndentP n first
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 =

6
src/REPL.hs
View File

@@ -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

6
src/Research.hs
View File

@@ -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

238
test/Spec.hs
View File

@@ -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 "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 "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"

2
tricu-apps/arboricxServer.tri
View File

@@ -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