mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-17 13:27:30 +03:00
454 lines
13 KiB
Plaintext
454 lines
13 KiB
Plaintext
|
|
a |> f = f a
|
|
f <| a = f a
|
|
|
|
uncurry f = cases (x, y) -> f x y
|
|
snd = cases (_, y) -> y
|
|
|
|
compose f g = a -> f (g a)
|
|
compose2 f g = a -> b -> f (g a b)
|
|
compose3 f g = a -> b -> c -> f (g a b c)
|
|
|
|
id a = a
|
|
void x = ()
|
|
|
|
structural ability Exception where
|
|
raise: io2.Failure -> anything
|
|
|
|
Exception.reraise : Either Failure a ->{Exception} a
|
|
Exception.reraise = cases
|
|
Left e -> Exception.raise e
|
|
Right a -> a
|
|
|
|
Either.isLeft = cases
|
|
Left _ -> true
|
|
Right _ -> false
|
|
|
|
Exception.catch : '{g, Exception} a ->{g} Either Failure a
|
|
Exception.catch ex =
|
|
handle !ex
|
|
with
|
|
cases
|
|
{ a } -> Right a
|
|
{Exception.raise f -> _} -> Left f
|
|
|
|
Either.raiseMessage v e = reraise (Either.mapLeft (msg -> failure msg v) e)
|
|
|
|
Either.mapLeft f = cases
|
|
Left l -> Left (f l)
|
|
Right r -> Right r
|
|
|
|
Exception.failure msg a = Failure (typeLink Unit) msg (Any a)
|
|
|
|
Exception.toEither.handler : Request {Exception} a -> Either Failure a
|
|
Exception.toEither.handler = cases
|
|
{ a } -> Right a
|
|
{Exception.raise f -> _} -> Left f
|
|
|
|
Exception.toEither : '{ε, Exception} a -> {ε} Either Failure a
|
|
Exception.toEither a = handle !a with Exception.toEither.handler
|
|
|
|
Exception.unsafeRun! : '{g, Exception} a ->{g} a
|
|
Exception.unsafeRun! e =
|
|
h : Request {Exception} a -> a
|
|
h = cases
|
|
{raise fail -> _} -> bug fail
|
|
{ a } -> a
|
|
handle !e with h
|
|
|
|
structural ability Throw e where
|
|
throw : e -> a
|
|
|
|
List.range : Nat -> Nat -> [Nat]
|
|
List.range m =
|
|
go acc n =
|
|
if n <= m then acc
|
|
else
|
|
n' = drop n 1
|
|
go (n' +: acc) n'
|
|
go []
|
|
|
|
List.all : (a ->{ε} Boolean) -> [a] ->{ε} Boolean
|
|
List.all f = cases
|
|
[] -> true
|
|
h +: t -> f h && all f t
|
|
|
|
List.foldLeft : (b ->{g} a ->{g} b) -> b -> [a] ->{g} b
|
|
List.foldLeft f b as =
|
|
go b i =
|
|
match List.at i as with
|
|
None -> b
|
|
Some a ->
|
|
use Nat +
|
|
go (f b a) (i + 1)
|
|
go b 0
|
|
|
|
List.filter: (a -> Boolean) -> [a] -> [a]
|
|
List.filter f all =
|
|
go acc = cases
|
|
[] -> acc
|
|
a +: as -> if (f a) then go (cons a acc) as else go acc as
|
|
go [] all
|
|
|
|
List.forEach : [a] -> (a ->{e} ()) ->{e} ()
|
|
List.forEach l f =
|
|
go = cases
|
|
x +: xs -> f x ; go xs
|
|
[] -> ()
|
|
go l
|
|
|
|
List.zip : [a] -> [b] -> [(a,b)]
|
|
List.zip = cases
|
|
[], _ -> []
|
|
_, [] -> []
|
|
x +: xs, y +: ys -> (x,y) +: List.zip xs ys
|
|
|
|
List.unzip : [(a,b)] -> ([a],[b])
|
|
List.unzip =
|
|
loop = cases
|
|
acc, [] -> acc
|
|
(as,bs), (a,b) +: abs ->
|
|
loop (as :+ a, bs :+ b) abs
|
|
loop ([],[])
|
|
|
|
List.reverse : [a] -> [a]
|
|
List.reverse =
|
|
loop acc = cases
|
|
[] -> acc
|
|
x +: xs -> loop (x +: acc) xs
|
|
loop []
|
|
|
|
first : (a -> b) -> (a,c) -> (b,c)
|
|
first f = cases (x,y) -> (f x, y)
|
|
|
|
check: Text -> Boolean -> {Stream Result} ()
|
|
check msg test = if test then emit (Ok msg) else emit (Fail msg)
|
|
|
|
checks : [Boolean] -> [Result]
|
|
checks bs =
|
|
if all id bs then [Ok "Passed"]
|
|
else [Fail "Failed"]
|
|
|
|
hex : Bytes -> Text
|
|
hex b =
|
|
match Bytes.toBase16 b |> fromUtf8.impl
|
|
with Left e -> bug e
|
|
Right t -> t
|
|
|
|
ascii : Text -> Bytes
|
|
ascii = toUtf8
|
|
|
|
fromHex : Text -> Bytes
|
|
fromHex txt =
|
|
match toUtf8 txt |> Bytes.fromBase16
|
|
with Left e -> bug e
|
|
Right bs -> bs
|
|
|
|
isNone = cases
|
|
Some _ -> false
|
|
None -> true
|
|
|
|
|
|
structural ability Stream a where
|
|
emit: a -> ()
|
|
|
|
Stream.toList.handler : Request {Stream a} r -> [a]
|
|
Stream.toList.handler =
|
|
go : [a] -> Request {Stream a} r -> [a]
|
|
go acc = cases
|
|
{ Stream.emit a -> k } -> handle !k with go (acc :+ a)
|
|
{ _ } -> acc
|
|
|
|
go []
|
|
|
|
Stream.toList : '{Stream a} r -> [a]
|
|
Stream.toList s = handle !s with toList.handler
|
|
|
|
Stream.collect.handler : Request {Stream a} r -> ([a],r)
|
|
Stream.collect.handler =
|
|
go : [a] -> Request {Stream a} r -> ([a],r)
|
|
go acc = cases
|
|
{ Stream.emit a -> k } -> handle !k with go (acc :+ a)
|
|
{ r } -> (acc, r)
|
|
|
|
go []
|
|
|
|
Stream.collect : '{e, Stream a} r -> {e} ([a],r)
|
|
Stream.collect s =
|
|
handle !s with Stream.collect.handler
|
|
|
|
|
|
-- An ability that facilitates creating temoporary directories that can be
|
|
-- automatically cleaned up
|
|
structural ability TempDirs where
|
|
newTempDir: Text -> Text
|
|
removeDir: Text -> ()
|
|
|
|
-- A handler for TempDirs which cleans up temporary directories
|
|
-- This will be useful for IO tests which need to interact with
|
|
-- the filesystem
|
|
|
|
autoCleaned.handler: '{io2.IO} (Request {TempDirs} r -> r)
|
|
autoCleaned.handler _ =
|
|
remover : [Text] -> {io2.IO} ()
|
|
remover = cases
|
|
a +: as -> match removeDirectory.impl a with
|
|
Left (Failure _ e _) -> watch e ()
|
|
_ -> ()
|
|
remover as
|
|
[] -> ()
|
|
|
|
go : [Text] -> {io2.IO} Request {TempDirs} r -> r
|
|
go dirs = cases
|
|
{ a } -> remover dirs
|
|
a
|
|
{ TempDirs.newTempDir prefix -> k } ->
|
|
dir = createTempDirectory prefix
|
|
handle k dir with go (dir +: dirs)
|
|
|
|
{ TempDirs.removeDir dir -> k } ->
|
|
removeDirectory dir
|
|
handle !k with go (filter (d -> not (d == dir)) dirs)
|
|
|
|
go []
|
|
|
|
autoCleaned: '{io2.IO, TempDirs} r -> r
|
|
autoCleaned comp = handle !comp with !autoCleaned.handler
|
|
|
|
stdout = IO.stdHandle StdOut
|
|
printText : Text -> {io2.IO} Either Failure ()
|
|
printText t = putBytes.impl stdout (toUtf8 t)
|
|
|
|
printLine : Text -> {io2.IO, Exception} ()
|
|
printLine t = reraise (printText (t ++ "\n"))
|
|
|
|
delay : Nat ->{IO, Exception} ()
|
|
delay n = reraise (delay.impl n)
|
|
-- Run tests which might fail, might create temporary directores and Stream out
|
|
-- results, returns the Results and the result of the test
|
|
evalTest: '{Stream Result, TempDirs, io2.IO, Exception} a ->{io2.IO, Exception}([Result], a)
|
|
evalTest a = handle (handle !a with Stream.collect.handler) with !autoCleaned.handler
|
|
|
|
-- Run tests which might fail, might create temporary directores and Stream out
|
|
-- results, but ignore the produced value and only return the test Results
|
|
runTest: '{Stream Result, Exception, TempDirs, Exception, io2.IO} a -> {io2.IO}[Result]
|
|
runTest t = handle evalTest t with cases
|
|
{ Exception.raise (Failure _ f _) -> _ } -> [ Fail ("Error running test: " ++ f) ]
|
|
{ (a, _) } -> a
|
|
|
|
expect : Text -> (a -> a -> Boolean) -> a -> a -> {Stream Result} ()
|
|
expect msg compare expected actual = if compare expected actual then emit (Ok msg) else emit (Fail msg)
|
|
|
|
expectU : Text -> a -> a -> {Stream Result} ()
|
|
expectU msg expected actual = expect msg (==) expected actual
|
|
|
|
startsWith: Text -> Text -> Boolean
|
|
startsWith prefix text = (eq (Text.take (size prefix) text) prefix)
|
|
|
|
contains : Text -> Text -> Boolean
|
|
contains needle haystack = if (size haystack) == 0 then false else
|
|
if startsWith needle haystack then true else
|
|
contains needle (drop 1 haystack)
|
|
|
|
isDirectory = compose reraise isDirectory.impl
|
|
createTempDirectory = compose reraise createTempDirectory.impl
|
|
directoryContents = compose reraise directoryContents.impl
|
|
getTempDirectory = compose reraise getTempDirectory.impl
|
|
removeDirectory = compose reraise removeDirectory.impl
|
|
fileExists = compose reraise fileExists.impl
|
|
renameDirectory = compose2 reraise renameDirectory.impl
|
|
openFile = compose2 reraise openFile.impl
|
|
isFileOpen = compose reraise isFileOpen.impl
|
|
closeFile = compose reraise closeFile.impl
|
|
isSeekable = compose reraise isSeekable.impl
|
|
isFileEOF = compose reraise isFileEOF.impl
|
|
Text.fromUtf8 = compose reraise fromUtf8.impl
|
|
getBytes = compose2 reraise getBytes.impl
|
|
getSomeBytes = compose2 reraise getSomeBytes.impl
|
|
handlePosition = compose reraise handlePosition.impl
|
|
getBuffering = compose reraise getBuffering.impl
|
|
setBuffering mode = compose reraise (setBuffering.impl mode)
|
|
setEcho = compose2 reraise setEcho.impl
|
|
getEcho = compose reraise getEcho.impl
|
|
getChar = compose reraise getChar.impl
|
|
ready = compose reraise ready.impl
|
|
seekHandle = compose3 reraise seekHandle.impl
|
|
putBytes = compose2 reraise putBytes.impl
|
|
getLine = compose reraise getLine.impl
|
|
systemTime = compose reraise systemTime.impl
|
|
decodeCert = compose reraise decodeCert.impl
|
|
serverSocket = compose2 reraise IO.serverSocket.impl
|
|
listen = compose reraise listen.impl
|
|
handshake = compose reraise handshake.impl
|
|
send = compose2 reraise Tls.send.impl
|
|
closeSocket = compose reraise closeSocket.impl
|
|
clientSocket = compose2 reraise IO.clientSocket.impl
|
|
receive = compose reraise receive.impl
|
|
terminate = compose reraise terminate.impl
|
|
newServer = compose2 reraise newServer.impl
|
|
socketAccept = compose reraise socketAccept.impl
|
|
socketPort = compose reraise socketPort.impl
|
|
newClient = compose2 reraise newClient.impl
|
|
MVar.take = compose reraise take.impl
|
|
MVar.read = compose reraise read.impl
|
|
MVar.put = compose2 reraise put.impl
|
|
MVar.swap = compose2 reraise MVar.swap.impl
|
|
|
|
-- Some functions for using a sorted list as a map
|
|
|
|
-- Given an association list sorted by a values, finds the corresponding
|
|
-- b value. It is also expected that the a values will be unique. If not,
|
|
-- which b is returned depends on the exact size of the list.
|
|
bSearch : [(a,b)] -> a -> Optional b
|
|
bSearch m k =
|
|
find l u =
|
|
i = (l+u)/2
|
|
if l >= u then None
|
|
else match at i m with
|
|
Some (k', v)
|
|
| k == k' -> Some v
|
|
| k > k' -> find (i+1) u
|
|
| otherwise -> find l i
|
|
None -> None
|
|
find 0 (size m)
|
|
|
|
-- Given a sorted association list, determine if an a value exists in the
|
|
-- list.
|
|
bContains : [(a,b)] -> a -> Boolean
|
|
bContains m k = match bSearch m k with
|
|
Some _ -> true
|
|
None -> false
|
|
|
|
-- Given a sorted association list, splits the list into the portion before
|
|
-- the given a value, and after the a value. The a value should only appear
|
|
-- once in the list to get a well defined split. Otherwise where the split
|
|
-- occurs will be chosen arbitrarily, based on which copy the binary search
|
|
-- finds.
|
|
bSplit : [(a,b)] -> a -> ([(a,b)], [(a,b)])
|
|
bSplit m k =
|
|
find l u =
|
|
i = (l+u)/2
|
|
if l >= u then (List.take l m, List.drop l m)
|
|
else match at i m with
|
|
Some (k', _)
|
|
| k == k' -> (List.take i m, List.drop (i+1) m)
|
|
| k > k' -> find (i+1) u
|
|
| otherwise -> find l i
|
|
None -> (m, [])
|
|
find 0 (size m)
|
|
|
|
-- Inserts a key-value pair into a sorted association list. This maintains
|
|
-- the invariant that the a values are unique, via bSplit throwing out an
|
|
-- association pair if there is an exact key match.
|
|
bInsert : [(a,b)] -> a -> b -> [(a,b)]
|
|
bInsert m k v = match bSplit m k with
|
|
(pre, post) -> pre ++ [(k,v)] ++ post
|
|
|
|
-- Yields a list with unique, sorted a keys via insertion sort.
|
|
bSort : [(a,b)] -> [(a,b)]
|
|
bSort = foldLeft (acc -> uncurry (bInsert acc)) []
|
|
|
|
-- Finding transitive dependencies
|
|
|
|
-- main logic, given a sorted list of found dependencies and a list of
|
|
-- dependencies to search, yields the sorted list of transitive
|
|
-- dependencies
|
|
--
|
|
-- Leaves out builtins, since they shouldn't be necessary, and can't be
|
|
-- transported/saved reliably.
|
|
crawl found = cases
|
|
[] -> found
|
|
ln +: rest
|
|
| Text.take 2 (Link.Term.toText ln) == "##" -> crawl found rest
|
|
| bContains found ln -> crawl found rest
|
|
| otherwise -> match Code.lookup ln with
|
|
Some code ->
|
|
crawl
|
|
(bInsert found ln code)
|
|
(rest ++ Code.dependencies code)
|
|
None -> crawl found rest
|
|
|
|
Code.transitiveDeps : Link.Term ->{IO} [(Link.Term, Code)]
|
|
Code.transitiveDeps base = crawl [] [base]
|
|
|
|
Value.transitiveDeps : Value ->{IO} [(Link.Term, Code)]
|
|
Value.transitiveDeps v = crawl [] (Value.dependencies v)
|
|
|
|
-- Save/load a value with its dependencies to a file for serialization testing.
|
|
saveSelfContained : a -> Text ->{IO, Exception} ()
|
|
saveSelfContained x path =
|
|
v = Value.value x
|
|
deps = Value.transitiveDeps v
|
|
cv = Value.value (deps, v)
|
|
bs = Bytes.toBase32 (Value.serialize cv)
|
|
writeFile path bs
|
|
|
|
readFile : Text ->{IO,Exception} Bytes
|
|
readFile path =
|
|
h = openFile path FileMode.Read
|
|
load acc =
|
|
if isFileEOF h then acc else load (acc ++ getBytes h 1024)
|
|
|
|
bs = load Bytes.empty
|
|
closeFile h
|
|
bs
|
|
|
|
writeFile : Text -> Bytes ->{IO,Exception} ()
|
|
writeFile path bs =
|
|
h = openFile path FileMode.Write
|
|
putBytes h bs
|
|
closeFile h
|
|
|
|
fail : Text -> b ->{Exception} c
|
|
fail msg x = raise (Failure (typeLink IOFailure) msg (Any x))
|
|
|
|
fromB32 : Bytes ->{Exception} Bytes
|
|
fromB32 bs32 = match fromBase32 bs32 with
|
|
Left msg -> fail ("base32 decoding failed: " ++ msg) bs32
|
|
Right bs -> bs
|
|
|
|
loadValueBytes : Bytes ->{Exception,IO} ([(Link.Term, Code)], Value)
|
|
loadValueBytes bs = match Value.deserialize bs with
|
|
Left err -> fail ("could not deserialize value: " ++ err) bs
|
|
Right sv -> match Value.load sv with
|
|
Left l -> fail "could not load value" l
|
|
Right v -> v
|
|
|
|
loadCodeBytes : Bytes ->{Exception} Code
|
|
loadCodeBytes bs = match Code.deserialize bs with
|
|
Left err -> fail ("could not deserialize code: " ++ err) bs
|
|
Right co -> co
|
|
|
|
cache : [(Link.Term, Code)] -> ()
|
|
cache deps =
|
|
match validateLinks deps with
|
|
Left rs -> fail "cache: missing binding group" rs
|
|
Right [] -> ()
|
|
Right rs -> fail "cache: rehash failed" rs
|
|
|
|
match cache_ deps with
|
|
[] -> ()
|
|
l -> fail "code not self-contained" l
|
|
|
|
loadSelfContained : Text ->{IO, Exception} a
|
|
loadSelfContained path =
|
|
bs = fromB32 (readFile path)
|
|
(deps, v) = loadValueBytes bs
|
|
cache deps
|
|
match Value.load v with
|
|
Left l -> fail "value missing deps" l
|
|
Right x -> x
|
|
|
|
saveTestCase : Text -> Text -> (a ->{} Text) -> a ->{IO,Exception} ()
|
|
saveTestCase name ver f i =
|
|
dir = "unison-src/transcripts-using-base/serialized-cases/"
|
|
sfile = dir ++ name ++ "." ++ ver ++ ".ser"
|
|
ofile = dir ++ name ++ ".out"
|
|
hfile = dir ++ name ++ "." ++ ver ++ ".hash"
|
|
|
|
output = f i
|
|
|
|
saveSelfContained (f, i) sfile
|
|
writeFile ofile (toUtf8 output)
|
|
writeFile hfile (Bytes.toBase32 (crypto.hash Sha3_512 (f, i)))
|