unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 02:25:39 +03:00
Code Issues Projects Releases Wiki Activity

more standard library - hashing functions, traversal, sequencing, folds

Browse Source
This commit is contained in:
Paul Chiusano 2016-08-22 17:00:52 -04:00
parent 1d4e3210d5
commit eb7a9fb785
5 changed files with 130 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
node/src/Unison/Runtime/ExtraBuiltins.hs
View File

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

18
shared/src/Unison/Node/Builtin.hs
View File

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

5
shared/src/Unison/Parsers.hs
View File

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

8
shared/tests/Unison/Test/Interpreter.hs
View File

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

32
unison-src/base.u
View File

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