mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
more standard library - hashing functions, traversal, sequencing, folds
This commit is contained in:
parent
1d4e3210d5
commit
eb7a9fb785
@ -60,15 +60,16 @@ makeAPI blockStore crypto = do
|
||||
pure (Series cp, Series ud)
|
||||
resourcePool <- RP.make 3 10 (Index.loadEncrypted blockStore crypto) Index.flush
|
||||
pure (\whnf -> map (\(r, o, t, m) -> Builtin r o t m)
|
||||
[ let r = R.Builtin "Index.unsafeEmpty"
|
||||
[ -- Index
|
||||
let r = R.Builtin "Index.empty!"
|
||||
op [self] = do
|
||||
ident <- Note.lift nextID
|
||||
Term.Distributed' (Term.Node self) <- whnf self
|
||||
pure . index self . Term.lit . Term.Text . Index.idToText $ ident
|
||||
op _ = fail "Index.unsafeEmpty unpossible"
|
||||
op _ = fail "Index.empty! unpossible"
|
||||
type' = unsafeParseType "forall k v. Node -> Index k v"
|
||||
in (r, Just (I.Primop 1 op), type', prefix "unsafeEmpty")
|
||||
, let r = R.Builtin "Index.unsafeLookup"
|
||||
in (r, Just (I.Primop 1 op), type', prefix "Index.empty!")
|
||||
, let r = R.Builtin "Index.lookup!"
|
||||
op [key, indexToken] = inject g indexToken key where
|
||||
inject g indexToken key = do
|
||||
i <- whnf indexToken
|
||||
@ -80,26 +81,26 @@ makeAPI blockStore crypto = do
|
||||
flip finally cleanup $ do
|
||||
result <- atomically $ Index.lookup (SAH.hash' k) db
|
||||
case result >>= (pure . SAH.deserializeTermFromBytes . snd) of
|
||||
Just (Left s) -> fail ("Index.unsafeLookup could not deserialize: " ++ s)
|
||||
Just (Left s) -> fail ("Index.lookup! could not deserialize: " ++ s)
|
||||
Just (Right t) -> pure $ some t
|
||||
Nothing -> pure none
|
||||
pure val
|
||||
g s k = pure $ Term.ref r `Term.app` s `Term.app` k
|
||||
op _ = fail "Index.unsafeLookup unpossible"
|
||||
op _ = fail "Index.lookup! unpossible"
|
||||
type' = unsafeParseType "forall k v. k -> Index k v -> Optional v"
|
||||
in (r, Just (I.Primop 2 op), type', prefix "unsafeLookup")
|
||||
in (r, Just (I.Primop 2 op), type', prefix "Index.lookup!")
|
||||
, let r = R.Builtin "Index.lookup"
|
||||
op [key, index] = do
|
||||
Index' node tok <- whnf index
|
||||
pure $
|
||||
Term.builtin "Remote.map" `Term.apps` [
|
||||
Term.builtin "Index.unsafeLookup" `Term.app` key,
|
||||
Term.builtin "Index.lookup!" `Term.app` key,
|
||||
Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
|
||||
]
|
||||
op _ = fail "Index.lookup unpossible"
|
||||
type' = unsafeParseType "forall k v. k -> Index k v -> Remote (Optional v)"
|
||||
in (r, Just (I.Primop 2 op), type', prefix "lookup")
|
||||
, let r = R.Builtin "Index.unsafeInsert"
|
||||
in (r, Just (I.Primop 2 op), type', prefix "Index.lookup")
|
||||
, let r = R.Builtin "Index.insert!"
|
||||
op [k, v, index] = inject g k v index where
|
||||
inject g k v index = do
|
||||
k' <- whnf k
|
||||
@ -114,20 +115,22 @@ makeAPI blockStore crypto = do
|
||||
>>= atomically
|
||||
pure unitRef
|
||||
g k v index = pure $ Term.ref r `Term.app` k `Term.app` v `Term.app` index
|
||||
op _ = fail "Index.unsafeInsert unpossible"
|
||||
op _ = fail "Index.insert! unpossible"
|
||||
type' = unsafeParseType "forall k v. k -> v -> Index k v -> Unit"
|
||||
in (r, Just (I.Primop 3 op), type', prefix "unsafeInsert")
|
||||
in (r, Just (I.Primop 3 op), type', prefix "Index.insert!")
|
||||
, let r = R.Builtin "Index.insert"
|
||||
op [key, value, index] = do
|
||||
Index' node tok <- whnf index
|
||||
pure $
|
||||
Term.builtin "Remote.map" `Term.apps` [
|
||||
Term.builtin "Index.unsafeInsert" `Term.apps` [key,value],
|
||||
Term.builtin "Index.insert!" `Term.apps` [key,value],
|
||||
Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
|
||||
]
|
||||
op _ = fail "Index.insert unpossible"
|
||||
type' = unsafeParseType "forall k v. k -> v -> Index k v -> Remote Unit"
|
||||
in (r, Just (I.Primop 3 op), type', prefix "insert")
|
||||
in (r, Just (I.Primop 3 op), type', prefix "Index.insert")
|
||||
|
||||
-- Html
|
||||
, let r = R.Builtin "Html.getLinks"
|
||||
op [html] = do
|
||||
html' <- whnf html
|
||||
@ -153,7 +156,9 @@ makeAPI blockStore crypto = do
|
||||
x -> Term.ref r `Term.app` x
|
||||
op _ = fail "Html.getDescription unpossible"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getDescription")
|
||||
, let r = R.Builtin "Http.unsafeGetURL"
|
||||
|
||||
-- Http
|
||||
, let r = R.Builtin "Http.getURL!"
|
||||
op [url] = do
|
||||
url <- whnf url
|
||||
case url of
|
||||
@ -163,11 +168,64 @@ makeAPI blockStore crypto = do
|
||||
Right x -> right $ Term.text x
|
||||
Left x -> left . Term.text . Text.pack $ show x
|
||||
x -> pure $ Term.ref r `Term.app` x
|
||||
op _ = fail "Http.unsafeGetURL unpossible"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "unsafeGetURL")
|
||||
op _ = fail "Http.getURL! unpossible"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "Http.getURL!")
|
||||
, let r = R.Builtin "Http.getURL"
|
||||
op [url] = pure $ Term.builtin "Remote.pure" `Term.app`
|
||||
(Term.builtin "Http.unsafeGetURL" `Term.app` url)
|
||||
(Term.builtin "Http.getURL!" `Term.app` url)
|
||||
op _ = fail "Http.getURL unpossible"
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Remote (Either Text Text)", prefix "getURL")
|
||||
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Remote (Either Text Text)", prefix "Http.getURL")
|
||||
|
||||
-- Hashing
|
||||
-- add erase, comparison functions
|
||||
, let r = R.Builtin "hash!"
|
||||
op [e] = do
|
||||
e <- whnf e
|
||||
pure $ Term.builtin "Hash" `Term.app` (Term.ref $ SAH.hash e)
|
||||
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.erase"
|
||||
op [e] = pure e
|
||||
op _ = fail "hash"
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
pure $ if r1 >= r2 then true else false
|
||||
op _ = fail "Hash.greaterThanOrEqual"
|
||||
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.greaterThanOrEqual")
|
||||
])
|
||||
|
||||
hashCompareTyp :: Type V
|
||||
hashCompareTyp = unsafeParseType "∀ a . Hash a -> Hash a -> Boolean"
|
||||
|
@ -70,6 +70,12 @@ makeBuiltins whnf =
|
||||
where g (Term.Text' x) (Term.Text' y) = Term.lit (Term.Text (f x y))
|
||||
g x y = sym `Term.app` x `Term.app` y
|
||||
_ -> error "unpossible"
|
||||
string2' :: Term V -> (Text -> Text -> Bool) -> I.Primop (N.Noted IO) V
|
||||
string2' sym f = I.Primop 2 $ \xs -> case xs of
|
||||
[x,y] -> g <$> whnf x <*> whnf y
|
||||
where g (Term.Text' x) (Term.Text' y) = if f x y then true else false
|
||||
g x y = sym `Term.app` x `Term.app` y
|
||||
_ -> error "unpossible"
|
||||
in map (\(r, o, t, m) -> Builtin r o t m)
|
||||
[ let r = R.Builtin "()"
|
||||
in (r, Nothing, unitT, prefix "()")
|
||||
@ -188,6 +194,17 @@ makeBuiltins whnf =
|
||||
-- Text
|
||||
, let r = R.Builtin "Text.concatenate"
|
||||
in (r, Just (string2 (Term.ref r) mappend), strOpTyp, prefixes ["concatenate", "Text"])
|
||||
, let r = R.Builtin "Text.equal"
|
||||
in (r, Just (string2' (Term.ref r) (==)), textCompareTyp, prefix "Text.equal")
|
||||
, let r = R.Builtin "Text.lessThan"
|
||||
in (r, Just (string2' (Term.ref r) (<)), textCompareTyp, prefix "Text.lessThan")
|
||||
, let r = R.Builtin "Text.lessThanOrEqual"
|
||||
in (r, Just (string2' (Term.ref r) (<=)), textCompareTyp, prefix "Text.lessThanOrEqual")
|
||||
, let r = R.Builtin "Text.greaterThan"
|
||||
in (r, Just (string2' (Term.ref r) (>)), textCompareTyp, prefix "Text.greaterThan")
|
||||
, let r = R.Builtin "Text.greaterThanOrEqual"
|
||||
in (r, Just (string2' (Term.ref r) (>=)), textCompareTyp, prefix "Text.greaterThanOrEqual")
|
||||
|
||||
, let r = R.Builtin "Text.left"
|
||||
in (r, Nothing, alignmentT, prefixes ["left", "Text"])
|
||||
, let r = R.Builtin "Text.right"
|
||||
@ -322,6 +339,7 @@ numOpTyp :: Type V
|
||||
numOpTyp = unsafeParseType "Number -> Number -> Number"
|
||||
numCompareTyp :: Type V
|
||||
numCompareTyp = unsafeParseType "Number -> Number -> Boolean"
|
||||
textCompareTyp = unsafeParseType "Text -> Text -> Boolean"
|
||||
strOpTyp :: Type V
|
||||
strOpTyp = unsafeParseType "Text -> Text -> Text"
|
||||
unitT :: Ord v => Type v
|
||||
|
@ -94,9 +94,6 @@ termBuiltins = (Var.named *** Term.ref) <$> (
|
||||
["fork", "receive", "receiveAsync", "pure", "bind", "channel", "send", "here", "at", "spawn"] []
|
||||
, AliasFromModule "Color" ["rgba"] []
|
||||
, AliasFromModule "Symbol" ["Symbol"] []
|
||||
, AliasFromModule "Index" ["lookup", "unsafeLookup", "insert", "unsafeInsert", "unsafeEmpty"] []
|
||||
, AliasFromModule "Html" ["getLinks", "getHref", "getDescription"] []
|
||||
, AliasFromModule "Http" ["getURL", "unsafeGetURL"] []
|
||||
] >>= unpackAliases)
|
||||
where
|
||||
unpackAliases :: Builtin -> [(Text, R.Reference)]
|
||||
@ -133,5 +130,7 @@ typeBuiltins = (Var.named *** Type.lit) <$>
|
||||
, builtin "Future"
|
||||
, builtin "Remote"
|
||||
, builtin "Node"
|
||||
-- hashing
|
||||
, builtin "Hash"
|
||||
]
|
||||
where builtin t = (t, Type.Ref $ R.Builtin t)
|
||||
|
@ -44,6 +44,14 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
|
||||
"[1,2,3,4,5]"
|
||||
, t "Vector.fold-balanced Vector.concatenate Vector.empty [[1],[2],[3,4],[5]]"
|
||||
"[1,2,3,4,5]"
|
||||
, t "Vector.fold-balanced (+) 0 [1,2,3]" "6"
|
||||
, 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"
|
||||
, t "if (Text.greaterThan \"hiya\" \"hi\") 1 2" "1"
|
||||
, t "if (Text.greaterThanOrEqual \"hiya\" \"hi\") 1 2" "1"
|
||||
, t "if (Text.greaterThanOrEqual \"hi\" \"hi\") 1 2" "1"
|
||||
, t "if (Text.lessThanOrEqual \"hi\" \"hi\") 1 2" "1"
|
||||
]
|
||||
t uneval eval = testCase (uneval ++ " ⟹ " ++ eval) $ do
|
||||
(node, _, builtins) <- node
|
||||
|
@ -20,18 +20,36 @@ Remote =
|
||||
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);
|
||||
|
||||
-- todo: figure out why typechecker bombs when try to annotate this
|
||||
-- Vector.fold-balanced : ∀ a . a -> (a -> a -> a) -> Vector a -> a;
|
||||
Vector.fold-balanced zero plus vs =
|
||||
Vector.fold-balanced : ∀ a . (a -> a -> a) -> a -> Vector a -> a;
|
||||
Vector.fold-balanced plus zero vs =
|
||||
let rec
|
||||
go zero plus vs =
|
||||
go plus zero vs =
|
||||
if (Vector.size vs <= 2)
|
||||
(Vector.fold-left zero plus vs)
|
||||
(Vector.fold-left plus zero vs)
|
||||
(let p = Vector.split vs;
|
||||
go zero plus (1st p) `Vector.concatenate` go zero plus (2nd p);;);
|
||||
go zero plus vs;;
|
||||
plus (go plus zero (1st p)) (go plus zero (2nd p));;);
|
||||
go plus zero vs;;
|
||||
;
|
||||
|
||||
Remote.lift2 : ∀ a b c . (a -> b -> c) -> Remote a -> Remote b -> Remote c;
|
||||
Remote.lift2 f a b = do Remote
|
||||
a := a;
|
||||
b := b;
|
||||
pure (f a b);;
|
||||
;
|
||||
|
||||
Remote.traverse : ∀ a b . (a -> Remote b) -> Vector a -> Remote (Vector b);
|
||||
Remote.traverse f vs =
|
||||
Vector.fold-balanced (Remote.lift2 Vector.concatenate)
|
||||
(Remote.pure Vector.empty)
|
||||
(Vector.map (f `then` Remote.map Vector.single) vs);
|
||||
|
||||
Remote.sequence : ∀ a . Vector (Remote a) -> Remote (Vector a);
|
||||
Remote.sequence vs =
|
||||
Vector.fold-balanced (Remote.lift2 Vector.concatenate)
|
||||
(Remote.pure Vector.empty)
|
||||
(Vector.map (Remote.map Vector.single) vs);
|
||||
|
||||
Optional.map : ∀ a b . (a -> b) -> Optional a -> Optional b;
|
||||
Optional.map f = Optional.fold None (f `then` Some);
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user