mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
lots of std lib improvements / fixes to support DIndex
This commit is contained in:
parent
1331400b1d
commit
a886c063b8
@ -13,6 +13,7 @@ import Unison.Type (Type)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified Unison.Cryptography as C
|
||||
import qualified Unison.Hash as Hash
|
||||
import qualified Unison.Eval.Interpreter as I
|
||||
import qualified Unison.Note as Note
|
||||
import qualified Unison.Reference as R
|
||||
@ -82,6 +83,21 @@ makeAPI blockStore crypto = do
|
||||
op _ = fail "Index.keys# unpossible"
|
||||
type' = unsafeParseType "forall k . Text -> Vector k"
|
||||
in (r, Just (I.Primop 1 op), type', prefix "Index.keys#")
|
||||
, let r = R.Builtin "Index.1st-key#"
|
||||
op [indexToken] = do
|
||||
Term.Text' h <- whnf indexToken
|
||||
Note.lift $ do
|
||||
(db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
|
||||
flip finally cleanup $ do
|
||||
keyBytes <- atomically $ Index.keys db
|
||||
case keyBytes of
|
||||
[] -> pure none
|
||||
(keyBytes:_) -> case SAH.deserializeTermFromBytes keyBytes of
|
||||
Left err -> fail ("Index.1st-key# could not deserialize: " ++ err)
|
||||
Right terms -> pure $ some terms
|
||||
op _ = fail "Index.1st-key# unpossible"
|
||||
type' = unsafeParseType "forall k . Text -> Optional k"
|
||||
in (r, Just (I.Primop 1 op), type', prefix "Index.1st-key#")
|
||||
, let r = R.Builtin "Index.increment#"
|
||||
op [key, indexToken] = do
|
||||
key <- whnf key
|
||||
@ -125,6 +141,17 @@ makeAPI blockStore crypto = do
|
||||
op _ = fail "Index.lookup# unpossible"
|
||||
type' = unsafeParseType "forall k v . k -> Text -> Optional v"
|
||||
in (r, Just (I.Primop 2 op), type', prefix "Index.lookup#")
|
||||
, let r = R.Builtin "Index.delete#"
|
||||
op [key, indexToken] = do
|
||||
Term.Text' indexToken <- whnf indexToken
|
||||
key <- whnf key
|
||||
(db, cleanup) <- Note.lift . RP.acquire resourcePool . Index.textToId $ indexToken
|
||||
Note.lift . flip finally cleanup $ do
|
||||
_ <- atomically $ Index.delete (SAH.hash' key) db
|
||||
pure unitRef
|
||||
op _ = fail "Index.delete# unpossible"
|
||||
type' = unsafeParseType "forall k . k -> Text -> Unit"
|
||||
in (r, Just (I.Primop 2 op), type', prefix "Index.delete#")
|
||||
, let r = R.Builtin "Index.insert#"
|
||||
op [k, v, index] = inject g k v index where
|
||||
inject g k v index = do
|
||||
@ -190,47 +217,55 @@ makeAPI blockStore crypto = do
|
||||
, let r = R.Builtin "hash#"
|
||||
op [e] = do
|
||||
e <- whnf e
|
||||
pure $ Term.builtin "Hash" `Term.app` (Term.ref $ SAH.hash e)
|
||||
let h = Hash.base64 . Hash.fromBytes . SAH.hash' $ e
|
||||
pure $ Term.builtin "Hash" `Term.app` (Term.text h)
|
||||
op _ = fail "hash"
|
||||
t = "forall a . a -> Hash a"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "hash#")
|
||||
, let r = R.Builtin "Hash.base64"
|
||||
op [e] = do
|
||||
Term.App' _ (Term.Text' r1) <- whnf e
|
||||
pure (Term.text r1)
|
||||
op _ = fail "Hash.base64"
|
||||
t = "forall a . Hash a -> Text"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "Hash.base64")
|
||||
, let r = R.Builtin "Hash.erase"
|
||||
op [e] = pure e
|
||||
op _ = fail "hash"
|
||||
op _ = fail "Hash.erase"
|
||||
t = "forall a . Hash a -> Hash Unit"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "Hash.erase")
|
||||
, let r = R.Builtin "Hash.equal"
|
||||
op [h1,h2] = do
|
||||
Term.App' _ (Term.Ref' r1) <- whnf h1
|
||||
Term.App' _ (Term.Ref' r2) <- whnf h2
|
||||
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||
pure $ if r1 == r2 then true else false
|
||||
op _ = fail "Hash.equal"
|
||||
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.equal")
|
||||
, let r = R.Builtin "Hash.lessThan"
|
||||
op [h1,h2] = do
|
||||
Term.App' _ (Term.Ref' r1) <- whnf h1
|
||||
Term.App' _ (Term.Ref' r2) <- whnf h2
|
||||
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||
pure $ if r1 < r2 then true else false
|
||||
op _ = fail "Hash.lessThan"
|
||||
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.lessThan")
|
||||
, let r = R.Builtin "Hash.lessThanOrEqual"
|
||||
op [h1,h2] = do
|
||||
Term.App' _ (Term.Ref' r1) <- whnf h1
|
||||
Term.App' _ (Term.Ref' r2) <- whnf h2
|
||||
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||
pure $ if r1 <= r2 then true else false
|
||||
op _ = fail "Hash.lessThanOrEqual"
|
||||
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.lessThanOrEqual")
|
||||
, let r = R.Builtin "Hash.greaterThan"
|
||||
op [h1,h2] = do
|
||||
Term.App' _ (Term.Ref' r1) <- whnf h1
|
||||
Term.App' _ (Term.Ref' r2) <- whnf h2
|
||||
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||
pure $ if r1 > r2 then true else false
|
||||
op _ = fail "Hash.greaterThan"
|
||||
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.greaterThan")
|
||||
, let r = R.Builtin "Hash.greaterThanOrEqual"
|
||||
op [h1,h2] = do
|
||||
Term.App' _ (Term.Ref' r1) <- whnf h1
|
||||
Term.App' _ (Term.Ref' r2) <- whnf h2
|
||||
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||
pure $ if r1 >= r2 then true else false
|
||||
op _ = fail "Hash.greaterThanOrEqual"
|
||||
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.greaterThanOrEqual")
|
||||
|
@ -120,7 +120,7 @@ server crypto allow env lang p = do
|
||||
-- guard $ Put.runPutS (serialize peerKey) == publicKey peer
|
||||
Mux.scope "Remote.server" . Mux.repeatWhile $ do
|
||||
r <- recv
|
||||
Mux.info $ "eval " ++ show r
|
||||
Mux.debug $ "eval " ++ show r
|
||||
case r of
|
||||
Nothing -> pure False
|
||||
Just (r, ackChan) -> do
|
||||
|
@ -41,6 +41,7 @@ main = do
|
||||
backend <- BasicNode.make SAH.hash store (\whnf -> b0 whnf ++ b1 whnf)
|
||||
loadDeclarations "unison-src/base.u" backend
|
||||
loadDeclarations "unison-src/extra.u" backend
|
||||
loadDeclarations "unison-src/dindex.u" backend
|
||||
initialized <- STM.atomically $ newTVar False
|
||||
pure $ go backend initialized
|
||||
where
|
||||
|
@ -9,6 +9,7 @@ import Unison.Symbol (Symbol)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Typechecker.Context (remoteSignatureOf)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified Data.Text as Text
|
||||
import qualified Unison.ABT as ABT
|
||||
@ -89,6 +90,33 @@ makeBuiltins whnf =
|
||||
in (r, Nothing, Type.builtin "Boolean", prefix "True")
|
||||
, let r = R.Builtin "False";
|
||||
in (r, Nothing, Type.builtin "Boolean", prefix "False")
|
||||
, let r = R.Builtin "Boolean.and";
|
||||
op [b1,b2] = do
|
||||
Term.Builtin' b1 <- whnf b1
|
||||
Term.Builtin' b2 <- whnf b2
|
||||
pure $ case (b1,b2) of
|
||||
_ | Text.head b1 /= Text.head b2 -> false
|
||||
| otherwise -> if Text.head b1 == 'T' then true else false
|
||||
op _ = error "unpossible"
|
||||
typ = "Boolean -> Boolean -> Boolean"
|
||||
in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "and")
|
||||
, let r = R.Builtin "Boolean.or";
|
||||
op [b1,b2] = do
|
||||
Term.Builtin' b1 <- whnf b1
|
||||
Term.Builtin' b2 <- whnf b2
|
||||
pure $ case (b1,b2) of
|
||||
_ | Text.head b1 /= Text.head b2 -> true
|
||||
| otherwise -> if Text.head b1 == 'F' then false else true
|
||||
op _ = error "unpossible"
|
||||
typ = "Boolean -> Boolean -> Boolean"
|
||||
in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "or")
|
||||
, let r = R.Builtin "Boolean.not";
|
||||
op [b1] = do
|
||||
Term.Builtin' b1 <- whnf b1
|
||||
pure $ if Text.head b1 == 'T' then false else true
|
||||
op _ = error "unpossible"
|
||||
typ = "Boolean -> Boolean"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "not")
|
||||
, let r = R.Builtin "Boolean.if";
|
||||
op [cond,t,f] = do
|
||||
cond <- whnf cond
|
||||
@ -124,7 +152,22 @@ makeBuiltins whnf =
|
||||
, let r = R.Builtin "Number.Order"
|
||||
in (r, Nothing, unsafeParseType "Order Number", prefix "Number.Order")
|
||||
|
||||
-- Duration
|
||||
, let r = R.Builtin "Duration.seconds"
|
||||
op [n] = do
|
||||
Term.Number' n <- whnf n
|
||||
pure $ Term.num n
|
||||
op _ = fail "Duration.seconds unpossible"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType "Number -> Duration", prefix "Duration.seconds")
|
||||
|
||||
-- Remote
|
||||
, let r = R.Builtin "Remote.delay"
|
||||
op [seconds] = do
|
||||
Term.Number' seconds <- whnf seconds
|
||||
N.lift $ threadDelay (floor $ seconds * 1000 * 1000)
|
||||
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Pure unitRef)))
|
||||
op _ = fail "Remote.at unpossible"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType "Duration -> Remote Unit", prefix "Remote.delay")
|
||||
, let r = R.Builtin "Remote.at"
|
||||
op [node,term] = do
|
||||
Term.Distributed' (Term.Node node) <- whnf node
|
||||
@ -171,19 +214,19 @@ makeBuiltins whnf =
|
||||
`Term.app` r
|
||||
op _ = fail "unpossible"
|
||||
in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.map", prefix "map")
|
||||
, let r = R.Builtin "Remote.receiveAsync"
|
||||
, let r = R.Builtin "Remote.receive-async"
|
||||
op [chan, timeout] = do
|
||||
Term.Number' seconds <- whnf timeout
|
||||
Term.Distributed' (Term.Channel chan) <- whnf chan
|
||||
pure $ Term.remote (Remote.Step (Remote.Local (Remote.ReceiveAsync chan (Remote.Seconds seconds))))
|
||||
op _ = fail "unpossible"
|
||||
in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.receiveAsync", prefix "receiveAsync")
|
||||
in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.receive-async", prefix "Remote.receive-async")
|
||||
, let r = R.Builtin "Remote.receive"
|
||||
op [chan] = do
|
||||
Term.Distributed' (Term.Channel chan) <- whnf chan
|
||||
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Receive chan)))
|
||||
op _ = fail "unpossible"
|
||||
in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.receive", prefix "receive")
|
||||
in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.receive", prefix "Remote.receive")
|
||||
, let r = R.Builtin "Remote.fork"
|
||||
op [r] = do
|
||||
Term.Distributed' (Term.Remote r) <- whnf r
|
||||
|
@ -129,6 +129,7 @@ typeBuiltins = (Var.named *** Type.lit) <$>
|
||||
, builtin "Html.Link"
|
||||
-- distributed
|
||||
, builtin "Channel"
|
||||
, builtin "Duration"
|
||||
, builtin "Future"
|
||||
, builtin "Remote"
|
||||
, builtin "Node"
|
||||
|
@ -594,22 +594,22 @@ remoteSignatureOf k = fromMaybe (error "unknown symbol") (Map.lookup k remoteSig
|
||||
|
||||
remoteSignatures :: forall v . Var v => Map.Map Text.Text (Type.Type v)
|
||||
remoteSignatures = Map.fromList
|
||||
[ ("Remote.at", Type.forall' ["a"] (Type.builtin "Node" --> v' "a" --> remote' (v' "a")))
|
||||
, ("Remote.fork", Type.forall' ["a"] (remote' (v' "a") --> remote' unitT))
|
||||
, ("Remote.here", remote' (Type.builtin "Node"))
|
||||
, ("Remote.spawn", remote' (Type.builtin "Node"))
|
||||
, ("Remote.send", Type.forall' ["a"] (channel (v' "a") --> v' "a" --> remote' unitT))
|
||||
, ("Remote.channel", Type.forall' ["a"] (remote' (channel (v' "a"))))
|
||||
, ("Remote.map", Type.forall' ["a","b"] ((v' "a" --> v' "b") --> remote' (v' "a") --> remote' (v' "b")))
|
||||
, ("Remote.bind", Type.forall' ["a","b"] ((v' "a" --> remote' (v' "b")) --> remote' (v' "a") --> remote' (v' "b")))
|
||||
, ("Remote.pure", Type.forall' ["a"] (v' "a" --> remote' (v' "a")))
|
||||
, ("Remote.receiveAsync", Type.forall' ["a"] (channel (v' "a") --> timeoutT --> remote' (remote' (v' "a"))))
|
||||
, ("Remote.receive", Type.forall' ["a"] (channel (v' "a") --> remote' (v' "a"))) ]
|
||||
[ ("Remote.at", Type.forall' ["a"] (Type.builtin "Node" --> v' "a" --> remote (v' "a")))
|
||||
, ("Remote.fork", Type.forall' ["a"] (remote (v' "a") --> remote unitT))
|
||||
, ("Remote.here", remote (Type.builtin "Node"))
|
||||
, ("Remote.spawn", remote (Type.builtin "Node"))
|
||||
, ("Remote.send", Type.forall' ["a"] (channel (v' "a") --> v' "a" --> remote unitT))
|
||||
, ("Remote.channel", Type.forall' ["a"] (remote (channel (v' "a"))))
|
||||
, ("Remote.map", Type.forall' ["a","b"] ((v' "a" --> v' "b") --> remote (v' "a") --> remote (v' "b")))
|
||||
, ("Remote.bind", Type.forall' ["a","b"] ((v' "a" --> remote (v' "b")) --> remote (v' "a") --> remote (v' "b")))
|
||||
, ("Remote.pure", Type.forall' ["a"] (v' "a" --> remote (v' "a")))
|
||||
, ("Remote.receive-async", Type.forall' ["a"] (channel (v' "a") --> timeoutT --> remote (remote (v' "a"))))
|
||||
, ("Remote.receive", Type.forall' ["a"] (channel (v' "a") --> remote (v' "a"))) ]
|
||||
where
|
||||
v' = Type.v'
|
||||
timeoutT = Type.builtin "Remote.Timeout"
|
||||
timeoutT = Type.builtin "Duration"
|
||||
unitT = Type.builtin "Unit"
|
||||
remote' t = Type.builtin "Remote" `Type.app` t
|
||||
remote t = Type.builtin "Remote" `Type.app` t
|
||||
channel t = Type.builtin "Channel" `Type.app` t
|
||||
|
||||
-- | For purposes of typechecking, we translate `[x,y,z]` to the term
|
||||
|
@ -23,6 +23,16 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
|
||||
, t "1 < 2" "True"
|
||||
, t "1 <= 1" "True"
|
||||
, t "1 >= 1" "True"
|
||||
, t "True `or` False" "True"
|
||||
, t "False `or` True" "True"
|
||||
, t "True `or` True" "True"
|
||||
, t "False `or` False" "False"
|
||||
, t "True `and` True" "True"
|
||||
, t "True `and` False" "False"
|
||||
, t "False `and` True" "False"
|
||||
, t "False `and` False" "False"
|
||||
, t "not False" "True"
|
||||
, t "not True" "False"
|
||||
, t "let rec fac n = if (n == 0) 1 (n * fac (n - 1)); fac 5;;" "120"
|
||||
, t "let rec ping n = if (n >= 10) n (pong (n + 1)); pong n = ping (n + 1); ping 0;;"
|
||||
"10"
|
||||
@ -37,6 +47,8 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
|
||||
, t "const 41 0" "41"
|
||||
, t "1st (1,2,3,4)" "1"
|
||||
, t "2nd (1,2 + 1,3,4)" "3"
|
||||
, t "identity <| (1 + 1)" "2"
|
||||
, t "(1 + 1) |> identity" "2"
|
||||
, t "if (Text.equal \"hi\" \"hi\") 1 2" "1"
|
||||
, t "if (Text.lessThan \"hi\" \"hiya\") 1 2" "1"
|
||||
, t "if (Text.lessThanOrEqual \"hi\" \"hiya\") 1 2" "1"
|
||||
@ -57,6 +69,8 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
|
||||
, t "Vector.fold-left (+) 0 (Vector.replicate 5 1)" "5"
|
||||
, t "Vector.sort Number.Order identity [5,2,1,3,4]" "[1,2,3,4,5]"
|
||||
, t "Vector.bind 2nd (Vector.zip [1,2,3] [[1],[2],[3]])" "[1,2,3]"
|
||||
, t "Vector.all? identity [True,True,True,True]" "True"
|
||||
, t "Vector.all? identity [True,False,True,True]" "False"
|
||||
, t "Optional.getOr 96 (Vector.at 1 [0,1,2,3,4])" "1"
|
||||
, t "Vector.take 0 [1,2,3]" "[]"
|
||||
, t "Vector.take 2 [1,2,3]" "[1,2]"
|
||||
|
@ -6,6 +6,12 @@ const x y = x;
|
||||
then : ∀ a b c . (a -> b) -> (b -> c) -> a -> c;
|
||||
then f1 f2 x = f2 (f1 x);
|
||||
|
||||
(|>) : ∀ a b . a -> (a -> b) -> b;
|
||||
a |> f = f a;
|
||||
|
||||
(<|) : ∀ a b . (a -> b) -> a -> b;
|
||||
f <| a = f a;
|
||||
|
||||
flip : ∀ a b c . (a -> b -> c) -> b -> a -> c;
|
||||
flip f b a = f a b;
|
||||
|
||||
@ -21,23 +27,14 @@ rest p = Pair.fold (x y -> y) p;
|
||||
4th = rest `then` (rest `then` (rest `then` first));
|
||||
5th = rest `then` (rest `then` (rest `then` (rest `then` first)));
|
||||
|
||||
Remote.transfer : Node -> Remote Unit;
|
||||
Remote.transfer node = Remote.at node unit;
|
||||
|
||||
Remote.map : ∀ a b . (a -> b) -> Remote a -> Remote b;
|
||||
Remote.map f = Remote.bind (f `then` Remote.pure);
|
||||
|
||||
Vector.replicate : ∀ a . Number -> a -> Vector a;
|
||||
Vector.replicate n a = Vector.map (const a) (Vector.range 0 n);
|
||||
|
||||
Remote.replicate : ∀ a . Number -> Remote a -> Remote (Vector a);
|
||||
Remote.replicate n r = Remote.sequence (Vector.replicate n r);
|
||||
|
||||
Vector.bind : ∀ a b . (a -> Vector b) -> Vector a -> Vector b;
|
||||
Vector.bind f v = Vector.fold-balanced Vector.concatenate Vector.empty (Vector.map f v);
|
||||
|
||||
Vector.pure = Vector.single;
|
||||
|
||||
Vector.replicate : ∀ a . Number -> a -> Vector a;
|
||||
Vector.replicate n a = Vector.map (const a) (Vector.range 0 n);
|
||||
|
||||
Vector.fold-right : ∀ a b . (a -> b -> b) -> b -> Vector a -> b;
|
||||
Vector.fold-right f z vs = Vector.fold-left (flip f) z (Vector.reverse vs);
|
||||
|
||||
@ -52,6 +49,38 @@ Vector.fold-balanced plus zero vs =
|
||||
go plus zero vs;;
|
||||
;
|
||||
|
||||
Vector.all? : ∀ a . (a -> Boolean) -> Vector a -> Boolean;
|
||||
Vector.all? f vs = Vector.fold-balanced and True (Vector.map f vs);
|
||||
|
||||
Remote.transfer : Node -> Remote Unit;
|
||||
Remote.transfer node = Remote.at node unit;
|
||||
|
||||
Remote.map : ∀ a b . (a -> b) -> Remote a -> Remote b;
|
||||
Remote.map f = Remote.bind (f `then` Remote.pure);
|
||||
|
||||
Remote.replicate : ∀ a . Number -> Remote a -> Remote (Vector a);
|
||||
Remote.replicate n r = Remote.sequence (Vector.replicate n r);
|
||||
|
||||
Remote.race : ∀ a . Duration -> Vector (Remote a) -> Remote a;
|
||||
Remote.race timeout rs = do Remote
|
||||
here := Remote.here;
|
||||
c := Remote.channel;
|
||||
result := Remote.receive-async c timeout;
|
||||
Remote.traverse
|
||||
(r -> Remote.fork <| do Remote a := r; Remote.transfer here; Remote.send c a;;)
|
||||
rs;
|
||||
result;;
|
||||
;
|
||||
|
||||
-- Returns `None` if no response within the provided `timeout`,
|
||||
-- which cannot exceed 500 seconds
|
||||
Remote.timeout : ∀ a . Duration -> Remote a -> Remote (Optional a);
|
||||
Remote.timeout timeout r =
|
||||
Remote.race (Duration.seconds 501) [
|
||||
Remote.map Some r,
|
||||
do Remote Remote.delay timeout; pure None;;
|
||||
];
|
||||
|
||||
Remote.lift2 : ∀ a b c . (a -> b -> c) -> Remote a -> Remote b -> Remote c;
|
||||
Remote.lift2 f a b = do Remote
|
||||
a := a;
|
||||
@ -59,6 +88,18 @@ Remote.lift2 f a b = do Remote
|
||||
pure (f a b);;
|
||||
;
|
||||
|
||||
Remote.at' : ∀ a . Node -> Remote a -> Remote a;
|
||||
Remote.at' node r = do Remote Remote.transfer node; r;;;
|
||||
|
||||
Remote.start : ∀ a . Duration -> Remote a -> Remote (Remote a);
|
||||
Remote.start timeout r = do Remote
|
||||
here := Remote.here;
|
||||
c := Remote.channel;
|
||||
result := Remote.receive-async c timeout;
|
||||
Remote.fork (Remote.at' here (r |> Remote.bind (Remote.send c)));
|
||||
pure result;;
|
||||
;
|
||||
|
||||
Remote.traverse : ∀ a b . (a -> Remote b) -> Vector a -> Remote (Vector b);
|
||||
Remote.traverse f vs =
|
||||
Vector.fold-balanced (Remote.lift2 Vector.concatenate)
|
||||
@ -71,6 +112,17 @@ Remote.sequence vs =
|
||||
(Remote.pure Vector.empty)
|
||||
(Vector.map (Remote.map Vector.single) vs);
|
||||
|
||||
Remote.parallel-traverse : ∀ a b . Duration -> (a -> Remote b) -> Vector a -> Remote (Vector b);
|
||||
Remote.parallel-traverse timeout f vs = do Remote
|
||||
futures := Remote.traverse (f `then` Remote.start timeout) vs;
|
||||
Remote.sequence futures;;
|
||||
;
|
||||
|
||||
-- Run several remote computations in parallel, returning once `n` equivalent
|
||||
-- replies come back. Equivalence is based on result of `hash!`.
|
||||
Remote.quorum : ∀ a b . Duration -> Number -> (a -> Remote b) -> Vector a -> Remote b;
|
||||
Remote.quorum timeout n = _; -- todo
|
||||
|
||||
Optional.map : ∀ a b . (a -> b) -> Optional a -> Optional b;
|
||||
Optional.map f = Optional.fold None (f `then` Some);
|
||||
|
||||
@ -83,6 +135,9 @@ Optional.pure = Some;
|
||||
Optional.getOr : ∀ a . a -> Optional a -> a;
|
||||
Optional.getOr a = Optional.fold a identity;
|
||||
|
||||
Optional.somes : ∀ a . Vector (Optional a) -> Vector a;
|
||||
Optional.somes = Vector.bind (Optional.fold Vector.empty Vector.single);
|
||||
|
||||
Either.map : ∀ a b c . (b -> c) -> Either a b -> Either a c;
|
||||
Either.map f = Either.fold Left (f `then` Right);
|
||||
|
||||
@ -94,4 +149,3 @@ Either.bind = Either.fold Left;
|
||||
|
||||
Either.swap : ∀ a b . Either a b -> Either b a;
|
||||
Either.swap e = Either.fold Right Left e;
|
||||
|
||||
|
97
unison-src/dindex.u
Normal file
97
unison-src/dindex.u
Normal file
@ -0,0 +1,97 @@
|
||||
-- A distributed index, using Highest Random Weight (HRW) hashing
|
||||
-- to pick which nodes are responsible for which keys. See:
|
||||
-- https://en.wikipedia.org/wiki/Rendezvous_hashing
|
||||
|
||||
DIndex.Replication-Factor = 3;
|
||||
DIndex.Timeout = Duration.seconds 10;
|
||||
DIndex.Max-Timeout = Duration.seconds 500;
|
||||
|
||||
DIndex.empty : ∀ k v . Remote (Index Node (Index k v));
|
||||
DIndex.empty = Index.empty;
|
||||
|
||||
-- Pick the nodes responsible for a key, using HRW hashing
|
||||
DIndex.nodesForKey : ∀ k v . k -> Index Node (Index k v) -> Remote (Vector Node);
|
||||
DIndex.nodesForKey k ind = do Remote
|
||||
nodes := Index.keys ind;
|
||||
hashes := Remote.traverse (node -> hash! (node, k)) nodes;
|
||||
(nodes `Vector.zip` hashes)
|
||||
|> Vector.sort Hash.Order 2nd
|
||||
|> Vector.take DIndex.Replication-Factor
|
||||
|> Vector.map 1st
|
||||
|> pure;;
|
||||
;
|
||||
|
||||
DIndex.lookup : ∀ k v . k -> Index Node (Index k v) -> Remote (Optional v);
|
||||
DIndex.lookup k ind = do Remote
|
||||
nodes := DIndex.nodesForKey k ind;
|
||||
localLookup = node -> (do Remote
|
||||
nind := Index.lookup node ind;
|
||||
-- on slim chance that a Node is removed from the cluster just before
|
||||
-- we do the lookup, it gets treated like a timeout
|
||||
Optional.fold (Remote.map (const None) (Remote.delay DIndex.Timeout))
|
||||
(Index.lookup k)
|
||||
nind;;)
|
||||
;
|
||||
-- todo: use Remote.quorum here
|
||||
-- Remote.race DIndex.Timeout <| Vector.map localLookup nodes;;
|
||||
rs := Remote.traverse localLookup nodes;
|
||||
pure (Vector.at 0 rs |> Optional.bind identity);;
|
||||
;
|
||||
|
||||
DIndex.insert : ∀ k v . k -> v -> Index Node (Index k v) -> Remote Unit;
|
||||
DIndex.insert k v ind = do Remote
|
||||
nodes := DIndex.nodesForKey k ind;
|
||||
localInsert = node -> (do Remote
|
||||
nind := Index.lookup node ind;
|
||||
Optional.fold (Remote.map (const Unit) (Remote.delay DIndex.Timeout))
|
||||
(Index.insert k v)
|
||||
nind;;)
|
||||
;
|
||||
Remote.race DIndex.Timeout <| Vector.map localInsert nodes;;
|
||||
;
|
||||
|
||||
DIndex.join : ∀ k v . Index Node (Index k v) -> Remote Unit;
|
||||
DIndex.join ind = do Remote
|
||||
here := Remote.here;
|
||||
localInd := Index.empty;
|
||||
Index.insert here localInd ind;;
|
||||
;
|
||||
|
||||
DIndex.indicesForKey : ∀ k v . k -> Index Node (Index k v) -> Remote (Vector (Index k v));
|
||||
DIndex.indicesForKey k ind = do Remote
|
||||
nodes := DIndex.nodesForKey k ind;
|
||||
indices := Remote.traverse (node -> Index.lookup node ind) nodes;
|
||||
pure (Optional.somes indices);;
|
||||
;
|
||||
|
||||
DIndex.rebalance : ∀ k v . k -> Index Node (Index k v) -> Remote Unit;
|
||||
DIndex.rebalance k ind = do Remote
|
||||
indices := DIndex.indicesForKey k ind;
|
||||
t = DIndex.Timeout;
|
||||
results := Remote.parallel-traverse DIndex.Max-Timeout (Index.lookup k `then` Remote.timeout t) indices;
|
||||
resultsHashes := Remote.traverse hash! results;
|
||||
uh := hash! None;
|
||||
hd = uh `Optional.getOr` Vector.at 0 resultsHashes;
|
||||
eq = h1 h2 -> Hash.equal (Hash.erase h1) (Hash.erase h2);
|
||||
if (Vector.all? (eq hd) resultsHashes)
|
||||
-- all results matched, we're good
|
||||
(pure Unit)
|
||||
-- not all results matched, reinsert
|
||||
(do Remote
|
||||
ov := DIndex.lookup k ind;
|
||||
Optional.fold (pure Unit)
|
||||
(v -> DIndex.insert k v ind)
|
||||
ov;;)
|
||||
;;
|
||||
;
|
||||
DIndex.leave : ∀ k v . Node -> Index Node (Index k v) -> Remote Unit;
|
||||
DIndex.leave node ind = do Remote
|
||||
local-ind := Index.lookup node ind;
|
||||
Index.delete node ind;
|
||||
Optional.fold
|
||||
(pure Unit)
|
||||
(local-ind -> do Remote
|
||||
keys := Index.keys local-ind;
|
||||
Remote.fork <| Remote.traverse (k -> DIndex.rebalance k ind) keys;;)
|
||||
local-ind;;
|
||||
;
|
@ -5,12 +5,18 @@ Index.empty = Remote.map Index.empty# Remote.here;
|
||||
Index.keys : ∀ k v . Index k v -> Remote (Vector k);
|
||||
Index.keys = Index.fromUnsafe Index.keys#;
|
||||
|
||||
Index.1st-key : ∀ k v . Index k v -> Remote (Optional k);
|
||||
Index.1st-key = Index.fromUnsafe Index.1st-key#;
|
||||
|
||||
Index.increment : ∀ k v . k -> Index k v -> Remote (Optional k);
|
||||
Index.increment k = Index.fromUnsafe (Index.increment# k);
|
||||
|
||||
Index.lookup : ∀ k v . k -> Index k v -> Remote (Optional v);
|
||||
Index.lookup k = Index.fromUnsafe (Index.lookup# k);
|
||||
|
||||
Index.delete : ∀ k v . k -> Index k v -> Remote Unit;
|
||||
Index.delete k = Index.fromUnsafe (Index.delete# k);
|
||||
|
||||
Index.insert : ∀ k v . k -> v -> Index k v -> Remote Unit;
|
||||
Index.insert k v = Index.fromUnsafe (Index.insert# k v);
|
||||
|
||||
@ -20,7 +26,8 @@ Index.fromUnsafe f ind = let
|
||||
Remote.map f (Remote.at (1st p) (2nd p));;
|
||||
;
|
||||
|
||||
-- todo: Index.delete
|
||||
|
||||
Http.getUrl : Text -> Remote (Either Text Text);
|
||||
Http.getUrl url = Remote.map Http.getUrl# (Remote.pure url);
|
||||
|
||||
hash! : ∀ a . a -> Remote (Hash a);
|
||||
hash! a = Remote.map hash# (Remote.pure a);
|
||||
|
Loading…
Reference in New Issue
Block a user