mirror of
https://github.com/ilyakooo0/airlock.git
synced 2024-08-16 22:10:26 +03:00
%sink
This commit is contained in:
parent
cd4f7e5dd1
commit
7f496c3605
GPG Key ID:
82C257048D1026F2
1
.gitignore
vendored
1
.gitignore
vendored
@ -1,2 +1,3 @@
|
||||
elm-stuff
|
||||
elm.js
|
||||
zod
|
||||
|
||||
@ -4,4 +4,4 @@ set -e
|
||||
|
||||
cd "$(dirname "$0")/../example"
|
||||
|
||||
nix run nixpkgs#elmPackages.elm-live -- src/Main.elm --start-page=index.html -- --output=elm.js --debug "$@"
|
||||
nix run nixpkgs#elmPackages.elm-live -- src/Sink.elm --start-page=index.html -- --output=elm.js --debug "$@"
|
||||
7
dev/vanilla-elm-live.sh
Executable file
7
dev/vanilla-elm-live.sh
Executable file
@ -0,0 +1,7 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -e
|
||||
|
||||
cd "$(dirname "$0")/../example"
|
||||
|
||||
nix run nixpkgs#elmPackages.elm-live -- src/Vanilla.elm --start-page=index.html -- --output=elm.js --debug "$@"
|
||||
@ -2,7 +2,22 @@ import { fetchEventSource } from "/fetch-event-source.js"
|
||||
|
||||
const uid = `${Math.floor(Date.now() / 1000)}-${Math.random()}`;
|
||||
|
||||
let app = Elm.Main.init({ node: document.getElementById("elm"), flags: { uid } });
|
||||
function searchForInit(obj) {
|
||||
if (obj.init) {
|
||||
return obj.init;
|
||||
} else {
|
||||
for (let key in obj) {
|
||||
if (obj.hasOwnProperty(key)) {
|
||||
const result = searchForInit(obj[key]);
|
||||
if (result) {
|
||||
return result;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
let app = searchForInit(Elm)({ node: document.getElementById("elm"), flags: { uid } });
|
||||
|
||||
app.ports.createEventSource.subscribe((url) => {
|
||||
fetchEventSource(url, {
|
||||
|
||||
204
example/src/Sink.elm
Normal file
204
example/src/Sink.elm
Normal file
@ -0,0 +1,204 @@
|
||||
port module Sink exposing (main)
|
||||
|
||||
import BigInt exposing (BigInt)
|
||||
import Browser exposing (Document)
|
||||
import Element exposing (..)
|
||||
import Element.Border as Border
|
||||
import Heroicons.Outline
|
||||
import Json.Decode as JD
|
||||
import Task
|
||||
import Time
|
||||
import Ur
|
||||
import Ur.Cmd
|
||||
import Ur.Constructor as C
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.Run
|
||||
import Ur.Sub
|
||||
import Ur.Types exposing (Noun)
|
||||
import Widget
|
||||
import Widget.Icon as Icon
|
||||
import Widget.Material as Material
|
||||
|
||||
|
||||
url : String
|
||||
url =
|
||||
"http://localhost:8080"
|
||||
|
||||
|
||||
main : Ur.Run.Program Model Msg
|
||||
main =
|
||||
Ur.Run.application
|
||||
{ init =
|
||||
\_ _ ->
|
||||
( { error = ""
|
||||
, entries = Nothing
|
||||
, newEntry = ""
|
||||
, shipName = Nothing
|
||||
}
|
||||
, Cmd.batch
|
||||
[ Ur.logIn url "lidlut-tabwed-pillex-ridrup"
|
||||
|> Cmd.map (result (Debug.toString >> Error) (always Noop))
|
||||
, Ur.getShipName url |> Cmd.map (result (always Noop) GotShipName)
|
||||
]
|
||||
|> Ur.Cmd.cmd
|
||||
)
|
||||
, update = update
|
||||
, view = view
|
||||
, subscriptions = always Sub.none
|
||||
, createEventSource = createEventSource
|
||||
, urbitSubscriptions =
|
||||
\{ shipName } ->
|
||||
case shipName of
|
||||
Just ship ->
|
||||
Ur.Sub.batch
|
||||
[ Ur.Sub.sink
|
||||
{ ship = ship
|
||||
, app = "journal"
|
||||
, path = [ "sync" ]
|
||||
, deconstructor =
|
||||
D.list (D.cell D.bigint D.cord |> D.map (\a b -> ( a, b )))
|
||||
|> D.map GotListings
|
||||
}
|
||||
]
|
||||
|
||||
_ ->
|
||||
Ur.Sub.none
|
||||
, onEventSourceMsg = onEventSourceMessage
|
||||
, onUrlChange = \_ -> Noop
|
||||
, onUrlRequest = \_ -> Noop
|
||||
, urbitUrl = \_ -> url
|
||||
}
|
||||
|
||||
|
||||
type alias Model =
|
||||
{ error : String
|
||||
, entries : Maybe (List ( BigInt, String ))
|
||||
, newEntry : String
|
||||
, shipName : Maybe String
|
||||
}
|
||||
|
||||
|
||||
type Msg
|
||||
= Noop
|
||||
| GotSink Noun
|
||||
| Error String
|
||||
| GotListings (List ( BigInt, String ))
|
||||
| UpdateNewEntry String
|
||||
| DeleteEntry BigInt
|
||||
| AddEntry String
|
||||
| RunCmd (Ur.Cmd.Cmd Msg)
|
||||
| GotShipName String
|
||||
|
||||
|
||||
update : Msg -> Model -> ( Model, Ur.Cmd.Cmd Msg )
|
||||
update msg model =
|
||||
case msg of
|
||||
Noop ->
|
||||
( model, Ur.Cmd.none )
|
||||
|
||||
GotSink _ ->
|
||||
( model, Ur.Cmd.none )
|
||||
|
||||
Error err ->
|
||||
( { model | error = err }, Ur.Cmd.none )
|
||||
|
||||
GotListings entries ->
|
||||
( { model | entries = Just entries }, Ur.Cmd.none )
|
||||
|
||||
UpdateNewEntry txt ->
|
||||
( { model | newEntry = txt }, Ur.Cmd.none )
|
||||
|
||||
DeleteEntry id ->
|
||||
( model
|
||||
, Ur.Cmd.poke
|
||||
{ ship = "~zod"
|
||||
, agent = "journal"
|
||||
, mark = "journal-action"
|
||||
, noun = C.cell (C.cord "del") (C.bigint id)
|
||||
}
|
||||
)
|
||||
|
||||
AddEntry txt ->
|
||||
( { model | newEntry = "" }
|
||||
, Time.now
|
||||
|> Task.perform
|
||||
(\time ->
|
||||
Ur.Cmd.poke
|
||||
{ ship = "~zod"
|
||||
, agent = "journal"
|
||||
, mark = "journal-action"
|
||||
, noun = C.cell (C.cord "add") (C.cell (time |> Time.posixToMillis |> BigInt.fromInt |> C.bigint) (C.cord txt))
|
||||
}
|
||||
|> RunCmd
|
||||
)
|
||||
|> Ur.Cmd.cmd
|
||||
)
|
||||
|
||||
RunCmd cmd ->
|
||||
( model, cmd )
|
||||
|
||||
GotShipName name ->
|
||||
( { model | shipName = Just name }, Ur.Cmd.none )
|
||||
|
||||
|
||||
view : Model -> Document Msg
|
||||
view model =
|
||||
{ body =
|
||||
[ layout []
|
||||
([ el [ alignTop ] (text model.error)
|
||||
, row [ spacing 8 ]
|
||||
[ Widget.textInput (Material.textInput Material.defaultPalette)
|
||||
{ chips = []
|
||||
, text = model.newEntry
|
||||
, placeholder = Nothing
|
||||
, label = "New entry"
|
||||
, onChange = UpdateNewEntry
|
||||
}
|
||||
, Widget.iconButton (Material.containedButton Material.defaultPalette)
|
||||
{ text = "submit"
|
||||
, icon = Icon.elmHeroicons Heroicons.Outline.check
|
||||
, onPress = AddEntry model.newEntry |> Just
|
||||
}
|
||||
]
|
||||
, model.entries
|
||||
|> Maybe.withDefault []
|
||||
|> List.map
|
||||
(\( id, txt ) ->
|
||||
row
|
||||
[ Border.rounded 10
|
||||
, Border.shadow { offset = ( 0, 5 ), size = 1, blur = 10, color = rgba 0 0 0 0.3 }
|
||||
, centerX
|
||||
, padding 10
|
||||
, spacing 12
|
||||
]
|
||||
[ paragraph [] [ text txt ]
|
||||
, Widget.iconButton (Material.containedButton Material.defaultPalette)
|
||||
{ text = "delete"
|
||||
, icon = Icon.elmHeroicons Heroicons.Outline.trash
|
||||
, onPress = DeleteEntry id |> Just
|
||||
}
|
||||
]
|
||||
)
|
||||
|> column [ spacing 10, centerX ]
|
||||
]
|
||||
|> column [ spacing 18, centerX ]
|
||||
)
|
||||
]
|
||||
, title = "Airlock"
|
||||
}
|
||||
|
||||
|
||||
result : (a -> c) -> (b -> c) -> Result a b -> c
|
||||
result f g res =
|
||||
case res of
|
||||
Ok b ->
|
||||
g b
|
||||
|
||||
Err a ->
|
||||
f a
|
||||
|
||||
|
||||
port createEventSource : String -> Cmd msg
|
||||
|
||||
|
||||
port onEventSourceMessage : (JD.Value -> msg) -> Sub msg
|
||||
@ -1,4 +1,4 @@
|
||||
port module Main exposing (main)
|
||||
port module Vanilla exposing (main)
|
||||
|
||||
import BigInt exposing (BigInt)
|
||||
import Browser exposing (Document)
|
||||
@ -12,7 +12,6 @@ import Ur
|
||||
import Ur.Cmd
|
||||
import Ur.Constructor as C
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.Requests
|
||||
import Ur.Run
|
||||
import Ur.Sub
|
||||
import Widget
|
||||
@ -20,6 +19,11 @@ import Widget.Icon as Icon
|
||||
import Widget.Material as Material
|
||||
|
||||
|
||||
url : String
|
||||
url =
|
||||
"http://localhost:8080"
|
||||
|
||||
|
||||
main : Ur.Run.Program Model Msg
|
||||
main =
|
||||
Ur.Run.application
|
||||
@ -31,11 +35,11 @@ main =
|
||||
, shipName = Nothing
|
||||
}
|
||||
, Cmd.batch
|
||||
[ Ur.logIn "http://localhost:8080" "lidlut-tabwed-pillex-ridrup"
|
||||
[ Ur.logIn url "lidlut-tabwed-pillex-ridrup"
|
||||
|> Cmd.map (result (Debug.toString >> Error) (always Noop))
|
||||
, Ur.getShipName "http://localhost:8080" |> Cmd.map (result (always Noop) GotShipName)
|
||||
, Ur.Requests.scry
|
||||
{ url = "http://localhost:8080"
|
||||
, Ur.getShipName url |> Cmd.map (result (always Noop) GotShipName)
|
||||
, Ur.scry
|
||||
{ url = url
|
||||
, agent = "journal"
|
||||
, path = [ "entries", "all" ]
|
||||
, error = Noop
|
||||
@ -69,7 +73,7 @@ main =
|
||||
, onEventSourceMsg = onEventSourceMessage
|
||||
, onUrlChange = \_ -> Noop
|
||||
, onUrlRequest = \_ -> Noop
|
||||
, urbitUrl = \_ -> "http://localhost:8080"
|
||||
, urbitUrl = \_ -> url
|
||||
}
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
/- *journal
|
||||
/+ default-agent, dbug, agentio
|
||||
/+ default-agent, dbug, agentio, *sink
|
||||
|%
|
||||
+$ versioned-state
|
||||
$% state-0
|
||||
@ -17,11 +17,18 @@
|
||||
?. (has:log-orm log unix-ms)
|
||||
unix-ms
|
||||
$(time (add unix-ms 1))
|
||||
--
|
||||
--
|
||||
|
||||
%- agent:dbug
|
||||
=| state-0
|
||||
=* state -
|
||||
=/ state *state-0
|
||||
=/ snik
|
||||
:: %-
|
||||
%+ sink ~[/sync]
|
||||
|=(stat=versioned-state (tap:j-orm journal.stat))
|
||||
:: !!
|
||||
=/ sink (snik state)
|
||||
^- agent:gall
|
||||
|
||||
|_ =bowl:gall
|
||||
+* this .
|
||||
def ~(. (default-agent this %|) bowl)
|
||||
@ -34,7 +41,8 @@
|
||||
++ on-load
|
||||
|= old-vase=vase
|
||||
^- (quip card _this)
|
||||
`this(state !<(versioned-state old-vase))
|
||||
=/ state !<(versioned-state old-vase)
|
||||
`this(state state, sink (snik state))
|
||||
::
|
||||
++ on-poke
|
||||
|= [=mark =vase]
|
||||
@ -42,27 +50,28 @@
|
||||
|^
|
||||
?> (team:title our.bowl src.bowl)
|
||||
?. ?=(%journal-action mark) (on-poke:def mark vase)
|
||||
=/ now=@ (unique-time now.bowl log)
|
||||
=/ now=@ (unique-time now.bowl log.state)
|
||||
=/ act !<(action vase)
|
||||
=. state (poke-action act)
|
||||
:_ this(log (put:log-orm log now act))
|
||||
~[(fact:io journal-update+!>(`update`[now act]) ~[/updates])]
|
||||
=^ card sink (sync:sink state)
|
||||
:_ this(log.state (put:log-orm log.state now act))
|
||||
~[(fact:io journal-update+!>(`update`[now act]) ~[/updates]) card]
|
||||
::
|
||||
++ poke-action
|
||||
|= act=action
|
||||
^- _state
|
||||
?- -.act
|
||||
%add
|
||||
?< (has:j-orm journal id.act)
|
||||
state(journal (put:j-orm journal id.act txt.act))
|
||||
?< (has:j-orm journal.state id.act)
|
||||
state(journal (put:j-orm journal.state id.act txt.act))
|
||||
::
|
||||
%edit
|
||||
?> (has:j-orm journal id.act)
|
||||
state(journal (put:j-orm journal id.act txt.act))
|
||||
?> (has:j-orm journal.state id.act)
|
||||
state(journal (put:j-orm journal.state id.act txt.act))
|
||||
::
|
||||
%del
|
||||
?> (has:j-orm journal id.act)
|
||||
state(journal +:(del:j-orm journal id.act))
|
||||
?> (has:j-orm journal.state id.act)
|
||||
state(journal +:(del:j-orm journal.state id.act))
|
||||
==
|
||||
--
|
||||
::
|
||||
@ -72,6 +81,7 @@
|
||||
?> (team:title our.bowl src.bowl)
|
||||
?+ path (on-watch:def path)
|
||||
[%updates ~] `this
|
||||
[%sync ~] [~[flush:sink] this]
|
||||
==
|
||||
::
|
||||
++ on-peek
|
||||
@ -85,14 +95,14 @@
|
||||
[%all ~]
|
||||
:^ ~ ~ %journal-update
|
||||
!> ^- update
|
||||
[now %jrnl (tap:j-orm journal)]
|
||||
[now %jrnl (tap:j-orm journal.state)]
|
||||
::
|
||||
[%before @ @ ~]
|
||||
=/ before=@ (rash i.t.t.t.path dem)
|
||||
=/ max=@ (rash i.t.t.t.t.path dem)
|
||||
:^ ~ ~ %journal-update
|
||||
!> ^- update
|
||||
[now %jrnl (tab:j-orm journal `before max)]
|
||||
[now %jrnl (tab:j-orm journal.state `before max)]
|
||||
::
|
||||
[%between @ @ ~]
|
||||
=/ start=@
|
||||
@ -101,7 +111,7 @@
|
||||
=/ end=@ (add 1 (rash i.t.t.t.t.path dem))
|
||||
:^ ~ ~ %journal-update
|
||||
!> ^- update
|
||||
[now %jrnl (tap:j-orm (lot:j-orm journal `end `start))]
|
||||
[now %jrnl (tap:j-orm (lot:j-orm journal.state `end `start))]
|
||||
==
|
||||
::
|
||||
[%x %updates *]
|
||||
@ -109,13 +119,13 @@
|
||||
[%all ~]
|
||||
:^ ~ ~ %journal-update
|
||||
!> ^- update
|
||||
[now %logs (tap:log-orm log)]
|
||||
[now %logs (tap:log-orm log.state)]
|
||||
::
|
||||
[%since @ ~]
|
||||
=/ since=@ (rash i.t.t.t.path dem)
|
||||
:^ ~ ~ %journal-update
|
||||
!> ^- update
|
||||
[now %logs (tap:log-orm (lot:log-orm log `since ~))]
|
||||
[now %logs (tap:log-orm (lot:log-orm log.state `since ~))]
|
||||
==
|
||||
==
|
||||
::
|
||||
227
example/urbit/lib/noun-diff.hoon
Normal file
227
example/urbit/lib/noun-diff.hoon
Normal file
@ -0,0 +1,227 @@
|
||||
=<
|
||||
|%
|
||||
++ diff
|
||||
|= [old=* new=*]
|
||||
^- patch
|
||||
=/ del (extract-del (oracle old new) old)
|
||||
=/ ins (extract-ins (oracle old new) new)
|
||||
=/ allowed-holes (~(int in (find-del-holes del)) (find-ins-holes ins))
|
||||
=. del (filter-del-holes allowed-holes del)
|
||||
=/ ins (filter-ins-holes allowed-holes ins)
|
||||
=/ closed-patch (closure (gcp [del ins]))
|
||||
?> =(& +.closed-patch)
|
||||
-.closed-patch
|
||||
++ apply
|
||||
|= [patch=_id noun=*]
|
||||
?- -.patch
|
||||
%diff
|
||||
=/ var-map (del del.patch noun)
|
||||
(ins ins.patch var-map)
|
||||
%cell
|
||||
?> ?=(^ noun)
|
||||
[$(patch lhs.patch, noun -.noun) $(patch rhs.patch, noun +.noun)]
|
||||
==
|
||||
++ id
|
||||
^- patch
|
||||
[%diff [%hole ~] [%hole ~]]
|
||||
+$ patch
|
||||
$%
|
||||
[%cell lhs=patch rhs=patch]
|
||||
[%diff ^diff]
|
||||
==
|
||||
--
|
||||
::
|
||||
|%
|
||||
+$ del-diff
|
||||
$%
|
||||
[%hole @]
|
||||
[%cell lhs=del-diff rhs=del-diff]
|
||||
[%ignore ~]
|
||||
==
|
||||
+$ ins-diff
|
||||
$%
|
||||
[%hole @ original=*]
|
||||
[%cell lhs=ins-diff rhs=ins-diff]
|
||||
[%atom @]
|
||||
==
|
||||
+$ final-ins-diff
|
||||
$%
|
||||
[%hole @]
|
||||
[%cell lhs=final-ins-diff rhs=final-ins-diff]
|
||||
[%atom @]
|
||||
==
|
||||
+$ diff [del=del-diff ins=final-ins-diff]
|
||||
+$ patch
|
||||
$%
|
||||
[%cell lhs=patch rhs=patch]
|
||||
[%diff diff]
|
||||
==
|
||||
++ insify-noun
|
||||
|= noun=*
|
||||
^- final-ins-diff
|
||||
?- noun
|
||||
^ [%cell $(noun -.noun) $(noun +.noun)]
|
||||
@ [%atom noun]
|
||||
==
|
||||
++ empty-set (silt `(list @)`~)
|
||||
++ find-del-holes
|
||||
|= diff=del-diff
|
||||
~+
|
||||
^- (set @)
|
||||
?- -.diff
|
||||
%hole (silt ~[+.diff])
|
||||
%cell
|
||||
(~(uni in $(diff lhs.diff)) $(diff rhs.diff))
|
||||
%ignore empty-set
|
||||
==
|
||||
++ find-final-ins-holes
|
||||
|= diff=final-ins-diff
|
||||
~+
|
||||
^- (set @)
|
||||
?- -.diff
|
||||
%hole (silt ~[+.diff])
|
||||
%cell
|
||||
(~(uni in $(diff lhs.diff)) $(diff rhs.diff))
|
||||
%atom empty-set
|
||||
==
|
||||
++ find-ins-holes
|
||||
|= diff=ins-diff
|
||||
~+
|
||||
^- (set @)
|
||||
?- -.diff
|
||||
%hole (silt ~[+<.diff])
|
||||
%cell
|
||||
(~(uni in $(diff lhs.diff)) $(diff rhs.diff))
|
||||
%atom empty-set
|
||||
==
|
||||
++ filter-del-holes
|
||||
|= [allowed-holes=(set @) diff=del-diff]
|
||||
^- del-diff
|
||||
?: ?=(%ignore -.diff) diff
|
||||
?- -.diff
|
||||
%hole
|
||||
?: (~(has in allowed-holes) +.diff) diff
|
||||
[%ignore ~]
|
||||
%cell [%cell $(diff +<.diff) $(diff +>.diff)]
|
||||
==
|
||||
++ filter-ins-holes
|
||||
|= [allowed-holes=(set @) diff=ins-diff]
|
||||
^- final-ins-diff
|
||||
?- -.diff
|
||||
%hole
|
||||
?: (~(has in allowed-holes) +<.diff) [%hole +<.diff]
|
||||
(insify-noun original:diff)
|
||||
%cell [%cell $(diff +<.diff) $(diff +>.diff)]
|
||||
%atom diff
|
||||
==
|
||||
++ gcp
|
||||
|= diff=diff
|
||||
^- patch
|
||||
?- -.ins.diff
|
||||
%atom
|
||||
[%diff diff]
|
||||
%cell
|
||||
?: ?=(%cell -.del.diff)
|
||||
[%cell $(diff [+<.del.diff +<.ins.diff]) $(diff [+>.del.diff +>.ins.diff])]
|
||||
[%diff diff]
|
||||
%hole
|
||||
[%diff diff]
|
||||
==
|
||||
++ closure
|
||||
|= =patch
|
||||
^- [^patch ?]
|
||||
?- -.patch
|
||||
%diff
|
||||
=/ del-holes (find-del-holes del:patch)
|
||||
=/ ins-holes (find-final-ins-holes ins:patch)
|
||||
=/ difference (~(dif in ins-holes) del-holes)
|
||||
[patch =(difference empty-set)]
|
||||
%cell
|
||||
=/ lhs $(patch lhs:patch)
|
||||
=/ rhs $(patch rhs:patch)
|
||||
?: ?&(+.lhs +.rhs) [[%cell -.lhs -.rhs] &]
|
||||
$(patch (pull-diff [%cell -.lhs -.rhs]))
|
||||
==
|
||||
++ pull-diff
|
||||
|= =patch
|
||||
^- [%diff del=del-diff ins=final-ins-diff]
|
||||
?- -.patch
|
||||
%diff patch
|
||||
%cell
|
||||
=/ pulled-lhs $(patch lhs:patch)
|
||||
=/ pulled-rhs $(patch rhs:patch)
|
||||
:+
|
||||
%diff
|
||||
[%cell del:pulled-lhs del:pulled-rhs]
|
||||
[%cell ins:pulled-lhs ins:pulled-rhs]
|
||||
==
|
||||
++ is-subtree
|
||||
|= [tree=* subtree=*]
|
||||
~+
|
||||
^- ?
|
||||
?: =(tree subtree) &
|
||||
?@ tree |
|
||||
?|
|
||||
(is-subtree -.tree subtree)
|
||||
(is-subtree +.tree subtree)
|
||||
==
|
||||
++ oracle
|
||||
|= [a=* b=*]
|
||||
|= subtree=*
|
||||
^- (unit @)
|
||||
?:
|
||||
?&
|
||||
(is-subtree a subtree)
|
||||
(is-subtree b subtree)
|
||||
==
|
||||
`(mug subtree)
|
||||
~
|
||||
++ extract-del
|
||||
|= [oracle=$-(* (unit @)) subtree=*]
|
||||
~+
|
||||
^- del-diff
|
||||
=/ hash (oracle subtree)
|
||||
?^ hash [%hole +.hash]
|
||||
?@ subtree [%ignore ~]
|
||||
[%cell (extract-del oracle -.subtree) (extract-del oracle +.subtree)]
|
||||
++ extract-ins
|
||||
|= [oracle=$-(* (unit @)) subtree=*]
|
||||
~+
|
||||
^- ins-diff
|
||||
=/ hash (oracle subtree)
|
||||
?^ hash [%hole +.hash subtree]
|
||||
?@ subtree [%atom subtree]
|
||||
[%cell (extract-ins oracle -.subtree) (extract-ins oracle +.subtree)]
|
||||
++ ins
|
||||
|= [diff=final-ins-diff var-map=(map @ *)]
|
||||
^- *
|
||||
?- -.diff
|
||||
%atom
|
||||
+.diff
|
||||
%cell
|
||||
[$(diff +<.diff) $(diff +>.diff)]
|
||||
%hole
|
||||
(~(got by var-map) +.diff)
|
||||
==
|
||||
++ del
|
||||
|= [diff=del-diff noun=*]
|
||||
^- (map @ *)
|
||||
|^ (go diff noun ((map @ *) ~))
|
||||
++ go
|
||||
|= [diff=del-diff noun=* var-map=(map @ *)]
|
||||
^- (map @ *)
|
||||
?- -.diff
|
||||
%ignore var-map
|
||||
%hole
|
||||
=/ subtree (~(get by var-map) +.diff)
|
||||
?~ subtree (~(put by var-map) +.diff noun)
|
||||
?> =(+.subtree noun)
|
||||
var-map
|
||||
%cell
|
||||
?> ?=(^ noun)
|
||||
=/ lhs-var-map $(diff +<.diff, noun -.noun)
|
||||
=/ rhs-var-map $(diff +>.diff, noun +.noun, var-map lhs-var-map)
|
||||
rhs-var-map
|
||||
==
|
||||
--
|
||||
--
|
||||
27
example/urbit/lib/sink.hoon
Normal file
27
example/urbit/lib/sink.hoon
Normal file
@ -0,0 +1,27 @@
|
||||
/+ noun-diff
|
||||
|%
|
||||
++ clog
|
||||
|$ [stut]
|
||||
$%
|
||||
[%flush stut]
|
||||
[%drain patch:noun-diff]
|
||||
==
|
||||
++ sink
|
||||
|* [pats=(list path) extract=$-(* *)]
|
||||
|* stat=*
|
||||
|@
|
||||
++ sync
|
||||
|= [stat=_stat]
|
||||
^- [card:agent:gall _..sync]
|
||||
=/ dif
|
||||
%+ diff:noun-diff (extract ^stat) (extract stat)
|
||||
:-
|
||||
~& [%give %fact pats %noun !>(^-((clog) [%drain dif]))]
|
||||
[%give %fact pats %noun !>(^-((clog) [%drain dif]))]
|
||||
..sync(stat stat)
|
||||
++ paths pats
|
||||
++ flush
|
||||
^- card:agent:gall
|
||||
[%give %fact pats %noun !>(^-((clog) [%flush (extract stat)]))]
|
||||
--
|
||||
--
|
||||
@ -6,16 +6,16 @@ module Ur.Deconstructor exposing
|
||||
, int, signedInt, bigint
|
||||
, float32, float64
|
||||
, cord, tape
|
||||
, bytes, sig, ignore, tar
|
||||
, bytes, sig, ignore, tar, lazy
|
||||
)
|
||||
|
||||
{-| This module provides an API to deconstruct `Noun`s into arbitrary Elm data structures.
|
||||
|
||||
The principal (and types) are very similar to `Url.Parser` from `elm/url`.
|
||||
|
||||
You would parse a `[%edit cord @]` like this:
|
||||
You would parse a `[%edit @ cord]` like this:
|
||||
|
||||
type alias Edit = {text : String, id: Int}
|
||||
type alias Edit = {id: Int, text : String}
|
||||
|
||||
(D.cell (D.const D.cord "edit") (D.cell D.int D.cord)) |> D.map Edit
|
||||
|
||||
@ -63,7 +63,7 @@ that "capture" a value: `D.int` and `D.cord`.
|
||||
|
||||
# Miscellaneous
|
||||
|
||||
@docs bytes, sig, ignore, tar
|
||||
@docs bytes, sig, ignore, tar, lazy
|
||||
|
||||
-}
|
||||
|
||||
@ -370,6 +370,17 @@ cell (Deconstructor l) (Deconstructor r) =
|
||||
)
|
||||
|
||||
|
||||
{-| -}
|
||||
lazy : (() -> Deconstructor a b) -> Deconstructor a b
|
||||
lazy f =
|
||||
Deconstructor
|
||||
(\noun a ->
|
||||
case f () of
|
||||
Deconstructor g ->
|
||||
g noun a
|
||||
)
|
||||
|
||||
|
||||
{-| Maps (applies) a function to all of the values deconstructed.
|
||||
|
||||
This is useful when you want to create a data type with extracted values as fields.
|
||||
|
||||
155
src/Ur/NounDiff.elm
Normal file
155
src/Ur/NounDiff.elm
Normal file
@ -0,0 +1,155 @@
|
||||
module Ur.NounDiff exposing (Patch, apply, deconstructPatch)
|
||||
|
||||
import Bytes.Extra
|
||||
import Dict exposing (Dict)
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.Types exposing (..)
|
||||
|
||||
|
||||
type Patch
|
||||
= PatchCell Patch Patch
|
||||
| Diff DelDiff InsDiff
|
||||
|
||||
|
||||
deconstructPatch : D.Deconstructor (Patch -> c) c
|
||||
deconstructPatch =
|
||||
D.oneOf
|
||||
[ D.cell (D.const D.cord "cell")
|
||||
(D.cell
|
||||
(D.lazy (\() -> deconstructPatch_))
|
||||
(D.lazy (\() -> deconstructPatch_))
|
||||
)
|
||||
|> D.map PatchCell
|
||||
, D.cell (D.const D.cord "diff") (D.cell deconstructDel deconstructIns) |> D.map Diff
|
||||
]
|
||||
|
||||
|
||||
deconstructPatch_ : D.Deconstructor (Patch -> c) c
|
||||
deconstructPatch_ =
|
||||
D.oneOf
|
||||
[ D.cell (D.const D.cord "cell")
|
||||
(D.cell
|
||||
deconstructPatch
|
||||
deconstructPatch
|
||||
)
|
||||
|> D.map PatchCell
|
||||
, D.cell (D.const D.cord "diff") (D.cell deconstructDel deconstructIns) |> D.map Diff
|
||||
]
|
||||
|
||||
|
||||
apply : Patch -> Noun -> Noun
|
||||
apply patch noun =
|
||||
case ( patch, noun ) of
|
||||
( PatchCell lhs rhs, Cell ( lhs_, rhs_ ) ) ->
|
||||
Cell ( apply lhs lhs_, apply rhs rhs_ )
|
||||
|
||||
( Diff delDiff insDiff, _ ) ->
|
||||
ins insDiff (del delDiff noun)
|
||||
|
||||
_ ->
|
||||
noun
|
||||
|
||||
|
||||
del : DelDiff -> Noun -> Dict Int Noun
|
||||
del diff noun =
|
||||
let
|
||||
go : DelDiff -> Noun -> Dict Int Noun -> Dict Int Noun
|
||||
go diff_ noun_ dict =
|
||||
case ( diff_, noun_ ) of
|
||||
( Ignore, _ ) ->
|
||||
dict
|
||||
|
||||
( DelCell lhsDiff rhsDiff, Cell ( lhs, rhs ) ) ->
|
||||
go lhsDiff lhs (go rhsDiff rhs dict)
|
||||
|
||||
( DelHole hole, _ ) ->
|
||||
-- There should be a continuity check here.
|
||||
-- Check that the noun_ is equal to whatever the hole maps to in dict.
|
||||
-- I don't include it for speed and laziness reasons.
|
||||
Dict.insert hole noun_ dict
|
||||
|
||||
_ ->
|
||||
dict
|
||||
in
|
||||
go diff noun Dict.empty
|
||||
|
||||
|
||||
ins : InsDiff -> Dict Int Noun -> Noun
|
||||
ins diff dict =
|
||||
case diff of
|
||||
InsAtom a ->
|
||||
Atom a
|
||||
|
||||
InsHole hole ->
|
||||
Dict.get hole dict |> Maybe.withDefault (Atom Bytes.Extra.empty)
|
||||
|
||||
InsCell lhs rhs ->
|
||||
Cell ( ins lhs dict, ins rhs dict )
|
||||
|
||||
|
||||
type DelDiff
|
||||
= Ignore
|
||||
| DelHole Int
|
||||
| DelCell DelDiff DelDiff
|
||||
|
||||
|
||||
deconstructDel : D.Deconstructor (DelDiff -> c) c
|
||||
deconstructDel =
|
||||
D.oneOf
|
||||
[ D.cell (D.const D.cord "ignore") D.ignore |> D.map Ignore
|
||||
, D.cell (D.const D.cord "hole") D.int |> D.map DelHole
|
||||
, D.cell (D.const D.cord "cell")
|
||||
(D.cell
|
||||
deconstructDel_
|
||||
deconstructDel_
|
||||
)
|
||||
|> D.map DelCell
|
||||
]
|
||||
|
||||
|
||||
deconstructDel_ : D.Deconstructor (DelDiff -> c) c
|
||||
deconstructDel_ =
|
||||
D.oneOf
|
||||
[ D.const D.cord "ignore" |> D.map Ignore
|
||||
, D.cell (D.const D.cord "hole") D.int |> D.map DelHole
|
||||
, D.cell (D.const D.cord "cell")
|
||||
(D.cell
|
||||
(D.lazy (\() -> deconstructDel))
|
||||
(D.lazy (\() -> deconstructDel))
|
||||
)
|
||||
|> D.map DelCell
|
||||
]
|
||||
|
||||
|
||||
type InsDiff
|
||||
= InsAtom Atom
|
||||
| InsHole Int
|
||||
| InsCell InsDiff InsDiff
|
||||
|
||||
|
||||
deconstructIns : D.Deconstructor (InsDiff -> c) c
|
||||
deconstructIns =
|
||||
D.oneOf
|
||||
[ D.cell (D.const D.cord "hole") D.int |> D.map InsHole
|
||||
, D.cell (D.const D.cord "atom") D.bytes |> D.map InsAtom
|
||||
, D.cell (D.const D.cord "cell")
|
||||
(D.cell
|
||||
deconstructIns_
|
||||
deconstructIns_
|
||||
)
|
||||
|> D.map InsCell
|
||||
]
|
||||
|
||||
|
||||
deconstructIns_ : D.Deconstructor (InsDiff -> c) c
|
||||
deconstructIns_ =
|
||||
D.oneOf
|
||||
[ D.cell (D.const D.cord "hole") D.int |> D.map InsHole
|
||||
, D.cell (D.const D.cord "atom") D.bytes |> D.map InsAtom
|
||||
, D.cell (D.const D.cord "cell")
|
||||
(D.cell
|
||||
(D.lazy (\() -> deconstructIns))
|
||||
(D.lazy (\() -> deconstructIns))
|
||||
)
|
||||
|> D.map InsCell
|
||||
]
|
||||
@ -18,6 +18,7 @@ import Ur.Cmd
|
||||
import Ur.Cmd.Internal
|
||||
import Ur.Constructor as C
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.NounDiff exposing (Patch, deconstructPatch)
|
||||
import Ur.Requests exposing (..)
|
||||
import Ur.Sub
|
||||
import Ur.Sub.Internal
|
||||
@ -32,6 +33,7 @@ type alias SubDict msg =
|
||||
( String, String, List String )
|
||||
{ deconstructor : D.Deconstructor (msg -> msg) msg
|
||||
, number : Int
|
||||
, sink : Bool
|
||||
}
|
||||
|
||||
|
||||
@ -49,6 +51,7 @@ type alias Model app msg =
|
||||
, eventId : Int
|
||||
, flags : Flags
|
||||
, requestsToRetry : List UrbitRequest
|
||||
, sinks : Dict Int Noun
|
||||
}
|
||||
|
||||
|
||||
@ -171,7 +174,6 @@ update inp msg model =
|
||||
( appModel, appCmds ) =
|
||||
inp.update msg_ model.app
|
||||
|
||||
-- { subscriptions, eventId, subscriptionRequests, subscriptionIntMapping } =
|
||||
subsResult =
|
||||
processUrSubs
|
||||
model.eventId
|
||||
@ -244,14 +246,51 @@ update inp msg model =
|
||||
Dict.get messageId model.subscriptionIntMapping
|
||||
|> Maybe.andThen (\key -> Dict.get key model.subscriptions)
|
||||
of
|
||||
Just { deconstructor } ->
|
||||
case D.run (D.cell D.ignore (D.cell D.ignore deconstructor)) rest of
|
||||
Just subMsg ->
|
||||
( model_, pureCmd (AppMsg subMsg) )
|
||||
Just { deconstructor, sink } ->
|
||||
if sink then
|
||||
case D.run (D.cell D.ignore (D.cell D.ignore deconstructSink)) rest of
|
||||
Just (Flush noun) ->
|
||||
( { model | sinks = Dict.insert messageId noun model.sinks }
|
||||
, case D.run deconstructor noun of
|
||||
Just subMsg ->
|
||||
pureCmd (AppMsg subMsg)
|
||||
|
||||
-- Got gargbage
|
||||
Nothing ->
|
||||
( model_, ackCmd )
|
||||
-- Got garbage
|
||||
Nothing ->
|
||||
Cmd.none
|
||||
)
|
||||
|
||||
Just (Drain patch) ->
|
||||
case Dict.get messageId model.sinks of
|
||||
Just oldNoun ->
|
||||
let
|
||||
newNoun =
|
||||
Ur.NounDiff.apply patch oldNoun
|
||||
in
|
||||
( { model | sinks = Dict.insert messageId newNoun model.sinks }
|
||||
, case D.run deconstructor newNoun of
|
||||
Just subMsg ->
|
||||
pureCmd (AppMsg subMsg)
|
||||
|
||||
Nothing ->
|
||||
Cmd.none
|
||||
)
|
||||
|
||||
Nothing ->
|
||||
( model, Cmd.none )
|
||||
|
||||
-- Got garbage
|
||||
Nothing ->
|
||||
( model, Cmd.none )
|
||||
|
||||
else
|
||||
case D.run (D.cell D.ignore (D.cell D.ignore deconstructor)) rest of
|
||||
Just subMsg ->
|
||||
( model_, pureCmd (AppMsg subMsg) )
|
||||
|
||||
-- Got gargbage
|
||||
Nothing ->
|
||||
( model_, ackCmd )
|
||||
|
||||
-- Got a fact for a subscription we do not hold
|
||||
Nothing ->
|
||||
@ -280,7 +319,7 @@ update inp msg model =
|
||||
|> tag model.eventId
|
||||
in
|
||||
( { model | eventId = eventId }
|
||||
, send { url = url, requests = reqs, success = OpenConnection, error = NeedsActivation }
|
||||
, send { url = url, requests = reqs, success = OpenConnection, error = Noop }
|
||||
)
|
||||
|
||||
Noop ->
|
||||
@ -307,6 +346,19 @@ update inp msg model =
|
||||
)
|
||||
|
||||
|
||||
type Sink
|
||||
= Flush Noun
|
||||
| Drain Patch
|
||||
|
||||
|
||||
deconstructSink : D.Deconstructor (Sink -> c) c
|
||||
deconstructSink =
|
||||
D.oneOf
|
||||
[ D.cell (D.const D.cord "flush") D.tar |> D.map Flush
|
||||
, D.cell (D.const D.cord "drain") deconstructPatch |> D.map Drain
|
||||
]
|
||||
|
||||
|
||||
processCmd : EventId -> Ur.Cmd.Cmd msg -> ( EventId, Cmd (Msg msg), List ( EventId, UrbitRequest ) )
|
||||
processCmd eventId urCmds =
|
||||
let
|
||||
@ -336,10 +388,10 @@ pureCmd msg =
|
||||
|
||||
processUrSubs :
|
||||
EventId
|
||||
-> Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId }
|
||||
-> Dict ( Ship, Agent, Path ) d
|
||||
-> Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId, sink : Bool }
|
||||
-> Dict ( Ship, Agent, Path ) { deconstructor : d, sink : Bool }
|
||||
->
|
||||
{ subscriptions : Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId }
|
||||
{ subscriptions : Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId, sink : Bool }
|
||||
, eventId : EventId
|
||||
, subscriptionRequests : List ( EventId, UrbitRequest )
|
||||
, subscriptionIntMapping : Dict EventId ( Ship, Agent, Path )
|
||||
@ -348,7 +400,7 @@ processUrSubs eventId existingSubscriptions urbitSubs_ =
|
||||
let
|
||||
urbitSubs =
|
||||
urbitSubs_
|
||||
|> Dict.map (\_ deconstructor -> { deconstructor = deconstructor })
|
||||
|> Dict.map (\_ { deconstructor, sink } -> { deconstructor = deconstructor, sink = sink })
|
||||
|
||||
( eventId_, newSubscriptionActions ) =
|
||||
Dict.diff urbitSubs existingSubscriptions
|
||||
@ -371,10 +423,11 @@ processUrSubs eventId existingSubscriptions urbitSubs_ =
|
||||
newSubscriptions =
|
||||
Dict.merge
|
||||
(\_ _ x -> x)
|
||||
(\key number { deconstructor } ->
|
||||
(\key number { deconstructor, sink } ->
|
||||
Dict.insert key
|
||||
{ deconstructor = deconstructor
|
||||
, number = number
|
||||
, sink = sink
|
||||
}
|
||||
)
|
||||
(\_ _ x -> x)
|
||||
@ -417,6 +470,7 @@ init inp ( app, appCmds ) flags =
|
||||
inp.urbitUrl app ++ "/~/channel/" ++ flags.uid
|
||||
in
|
||||
( { subscriptions = subsResult.subscriptions
|
||||
, sinks = Dict.empty
|
||||
, subscriptionIntMapping = subsResult.subscriptionIntMapping
|
||||
, app = app
|
||||
, connected = False
|
||||
@ -439,7 +493,7 @@ init inp ( app, appCmds ) flags =
|
||||
|
||||
subscriptions :
|
||||
{ a | subscriptions : b -> Sub msg, onEventSourceMsg : (JD.Value -> Msg c) -> Sub (Msg msg) }
|
||||
-> { d | app : b, requestsToRetry : List e }
|
||||
-> { d | app : b, requestsToRetry : List e, connected : Bool }
|
||||
-> Sub (Msg msg)
|
||||
subscriptions inp model =
|
||||
Sub.batch
|
||||
@ -450,4 +504,9 @@ subscriptions inp model =
|
||||
|
||||
else
|
||||
Time.every 1000 (always RetryRequests)
|
||||
, if not model.connected then
|
||||
Time.every 10000 (always NeedsActivation)
|
||||
|
||||
else
|
||||
Sub.none
|
||||
]
|
||||
|
||||
@ -1,4 +1,7 @@
|
||||
module Ur.Sub exposing (Sub, subscribe, none, batch)
|
||||
module Ur.Sub exposing
|
||||
( Sub, subscribe, none, batch
|
||||
, sink
|
||||
)
|
||||
|
||||
{-| This module is conceptually similar to `Platform.Sub`, but also you to subscribe to Urbit channels.
|
||||
|
||||
@ -29,7 +32,22 @@ type alias Sub msg =
|
||||
-}
|
||||
subscribe : { ship : String, app : String, path : List String, deconstructor : D.Deconstructor (msg -> msg) msg } -> Sub msg
|
||||
subscribe { ship, app, path, deconstructor } =
|
||||
Dict.singleton ( ship, app, path ) deconstructor |> Ur.Sub.Internal.Sub
|
||||
Dict.singleton ( ship, app, path )
|
||||
{ deconstructor = deconstructor
|
||||
, sink = False
|
||||
}
|
||||
|> Ur.Sub.Internal.Sub
|
||||
|
||||
|
||||
{-| Create a Sink subscription.
|
||||
-}
|
||||
sink : { ship : String, app : String, path : List String, deconstructor : D.Deconstructor (msg -> msg) msg } -> Sub msg
|
||||
sink { ship, app, path, deconstructor } =
|
||||
Dict.singleton ( ship, app, path )
|
||||
{ deconstructor = deconstructor
|
||||
, sink = True
|
||||
}
|
||||
|> Ur.Sub.Internal.Sub
|
||||
|
||||
|
||||
{-| A subscription that does exactly nothing. (Does not subscribe to anything)
|
||||
|
||||
@ -10,5 +10,7 @@ type Sub msg
|
||||
(Dict
|
||||
-- key is (ship, app, path)
|
||||
( Ship, Agent, Path )
|
||||
(D.Deconstructor (msg -> msg) msg)
|
||||
{ deconstructor : D.Deconstructor (msg -> msg) msg
|
||||
, sink : Bool
|
||||
}
|
||||
)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user