Ergonomic language features and lib cleanup
+ 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:
@@ -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
46
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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
417
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 :
|
||||
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))
|
||||
|
||||
|
||||
@@ -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
315
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)))
|
||||
|
||||
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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user