mirror of
https://github.com/ilyakooo0/airlock.git
synced 2024-09-21 07:18:15 +03:00
%sink
This commit is contained in:
parent
cd4f7e5dd1
commit
7f496c3605
1
.gitignore
vendored
1
.gitignore
vendored
@ -1,2 +1,3 @@
|
|||||||
elm-stuff
|
elm-stuff
|
||||||
elm.js
|
elm.js
|
||||||
|
zod
|
||||||
|
@ -4,4 +4,4 @@ set -e
|
|||||||
|
|
||||||
cd "$(dirname "$0")/../example"
|
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()}`;
|
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) => {
|
app.ports.createEventSource.subscribe((url) => {
|
||||||
fetchEventSource(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 BigInt exposing (BigInt)
|
||||||
import Browser exposing (Document)
|
import Browser exposing (Document)
|
||||||
@ -12,7 +12,6 @@ import Ur
|
|||||||
import Ur.Cmd
|
import Ur.Cmd
|
||||||
import Ur.Constructor as C
|
import Ur.Constructor as C
|
||||||
import Ur.Deconstructor as D
|
import Ur.Deconstructor as D
|
||||||
import Ur.Requests
|
|
||||||
import Ur.Run
|
import Ur.Run
|
||||||
import Ur.Sub
|
import Ur.Sub
|
||||||
import Widget
|
import Widget
|
||||||
@ -20,6 +19,11 @@ import Widget.Icon as Icon
|
|||||||
import Widget.Material as Material
|
import Widget.Material as Material
|
||||||
|
|
||||||
|
|
||||||
|
url : String
|
||||||
|
url =
|
||||||
|
"http://localhost:8080"
|
||||||
|
|
||||||
|
|
||||||
main : Ur.Run.Program Model Msg
|
main : Ur.Run.Program Model Msg
|
||||||
main =
|
main =
|
||||||
Ur.Run.application
|
Ur.Run.application
|
||||||
@ -31,11 +35,11 @@ main =
|
|||||||
, shipName = Nothing
|
, shipName = Nothing
|
||||||
}
|
}
|
||||||
, Cmd.batch
|
, 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))
|
|> Cmd.map (result (Debug.toString >> Error) (always Noop))
|
||||||
, Ur.getShipName "http://localhost:8080" |> Cmd.map (result (always Noop) GotShipName)
|
, Ur.getShipName url |> Cmd.map (result (always Noop) GotShipName)
|
||||||
, Ur.Requests.scry
|
, Ur.scry
|
||||||
{ url = "http://localhost:8080"
|
{ url = url
|
||||||
, agent = "journal"
|
, agent = "journal"
|
||||||
, path = [ "entries", "all" ]
|
, path = [ "entries", "all" ]
|
||||||
, error = Noop
|
, error = Noop
|
||||||
@ -69,7 +73,7 @@ main =
|
|||||||
, onEventSourceMsg = onEventSourceMessage
|
, onEventSourceMsg = onEventSourceMessage
|
||||||
, onUrlChange = \_ -> Noop
|
, onUrlChange = \_ -> Noop
|
||||||
, onUrlRequest = \_ -> Noop
|
, onUrlRequest = \_ -> Noop
|
||||||
, urbitUrl = \_ -> "http://localhost:8080"
|
, urbitUrl = \_ -> url
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
|||||||
/- *journal
|
/- *journal
|
||||||
/+ default-agent, dbug, agentio
|
/+ default-agent, dbug, agentio, *sink
|
||||||
|%
|
|%
|
||||||
+$ versioned-state
|
+$ versioned-state
|
||||||
$% state-0
|
$% state-0
|
||||||
@ -18,10 +18,17 @@
|
|||||||
unix-ms
|
unix-ms
|
||||||
$(time (add unix-ms 1))
|
$(time (add unix-ms 1))
|
||||||
--
|
--
|
||||||
|
|
||||||
%- agent:dbug
|
%- agent:dbug
|
||||||
=| state-0
|
=/ state *state-0
|
||||||
=* state -
|
=/ snik
|
||||||
|
:: %-
|
||||||
|
%+ sink ~[/sync]
|
||||||
|
|=(stat=versioned-state (tap:j-orm journal.stat))
|
||||||
|
:: !!
|
||||||
|
=/ sink (snik state)
|
||||||
^- agent:gall
|
^- agent:gall
|
||||||
|
|
||||||
|_ =bowl:gall
|
|_ =bowl:gall
|
||||||
+* this .
|
+* this .
|
||||||
def ~(. (default-agent this %|) bowl)
|
def ~(. (default-agent this %|) bowl)
|
||||||
@ -34,7 +41,8 @@
|
|||||||
++ on-load
|
++ on-load
|
||||||
|= old-vase=vase
|
|= old-vase=vase
|
||||||
^- (quip card _this)
|
^- (quip card _this)
|
||||||
`this(state !<(versioned-state old-vase))
|
=/ state !<(versioned-state old-vase)
|
||||||
|
`this(state state, sink (snik state))
|
||||||
::
|
::
|
||||||
++ on-poke
|
++ on-poke
|
||||||
|= [=mark =vase]
|
|= [=mark =vase]
|
||||||
@ -42,27 +50,28 @@
|
|||||||
|^
|
|^
|
||||||
?> (team:title our.bowl src.bowl)
|
?> (team:title our.bowl src.bowl)
|
||||||
?. ?=(%journal-action mark) (on-poke:def mark vase)
|
?. ?=(%journal-action mark) (on-poke:def mark vase)
|
||||||
=/ now=@ (unique-time now.bowl log)
|
=/ now=@ (unique-time now.bowl log.state)
|
||||||
=/ act !<(action vase)
|
=/ act !<(action vase)
|
||||||
=. state (poke-action act)
|
=. state (poke-action act)
|
||||||
:_ this(log (put:log-orm log now act))
|
=^ card sink (sync:sink state)
|
||||||
~[(fact:io journal-update+!>(`update`[now act]) ~[/updates])]
|
:_ this(log.state (put:log-orm log.state now act))
|
||||||
|
~[(fact:io journal-update+!>(`update`[now act]) ~[/updates]) card]
|
||||||
::
|
::
|
||||||
++ poke-action
|
++ poke-action
|
||||||
|= act=action
|
|= act=action
|
||||||
^- _state
|
^- _state
|
||||||
?- -.act
|
?- -.act
|
||||||
%add
|
%add
|
||||||
?< (has:j-orm journal id.act)
|
?< (has:j-orm journal.state id.act)
|
||||||
state(journal (put:j-orm journal id.act txt.act))
|
state(journal (put:j-orm journal.state id.act txt.act))
|
||||||
::
|
::
|
||||||
%edit
|
%edit
|
||||||
?> (has:j-orm journal id.act)
|
?> (has:j-orm journal.state id.act)
|
||||||
state(journal (put:j-orm journal id.act txt.act))
|
state(journal (put:j-orm journal.state id.act txt.act))
|
||||||
::
|
::
|
||||||
%del
|
%del
|
||||||
?> (has:j-orm journal id.act)
|
?> (has:j-orm journal.state id.act)
|
||||||
state(journal +:(del:j-orm journal id.act))
|
state(journal +:(del:j-orm journal.state id.act))
|
||||||
==
|
==
|
||||||
--
|
--
|
||||||
::
|
::
|
||||||
@ -72,6 +81,7 @@
|
|||||||
?> (team:title our.bowl src.bowl)
|
?> (team:title our.bowl src.bowl)
|
||||||
?+ path (on-watch:def path)
|
?+ path (on-watch:def path)
|
||||||
[%updates ~] `this
|
[%updates ~] `this
|
||||||
|
[%sync ~] [~[flush:sink] this]
|
||||||
==
|
==
|
||||||
::
|
::
|
||||||
++ on-peek
|
++ on-peek
|
||||||
@ -85,14 +95,14 @@
|
|||||||
[%all ~]
|
[%all ~]
|
||||||
:^ ~ ~ %journal-update
|
:^ ~ ~ %journal-update
|
||||||
!> ^- update
|
!> ^- update
|
||||||
[now %jrnl (tap:j-orm journal)]
|
[now %jrnl (tap:j-orm journal.state)]
|
||||||
::
|
::
|
||||||
[%before @ @ ~]
|
[%before @ @ ~]
|
||||||
=/ before=@ (rash i.t.t.t.path dem)
|
=/ before=@ (rash i.t.t.t.path dem)
|
||||||
=/ max=@ (rash i.t.t.t.t.path dem)
|
=/ max=@ (rash i.t.t.t.t.path dem)
|
||||||
:^ ~ ~ %journal-update
|
:^ ~ ~ %journal-update
|
||||||
!> ^- update
|
!> ^- update
|
||||||
[now %jrnl (tab:j-orm journal `before max)]
|
[now %jrnl (tab:j-orm journal.state `before max)]
|
||||||
::
|
::
|
||||||
[%between @ @ ~]
|
[%between @ @ ~]
|
||||||
=/ start=@
|
=/ start=@
|
||||||
@ -101,7 +111,7 @@
|
|||||||
=/ end=@ (add 1 (rash i.t.t.t.t.path dem))
|
=/ end=@ (add 1 (rash i.t.t.t.t.path dem))
|
||||||
:^ ~ ~ %journal-update
|
:^ ~ ~ %journal-update
|
||||||
!> ^- 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 *]
|
[%x %updates *]
|
||||||
@ -109,13 +119,13 @@
|
|||||||
[%all ~]
|
[%all ~]
|
||||||
:^ ~ ~ %journal-update
|
:^ ~ ~ %journal-update
|
||||||
!> ^- update
|
!> ^- update
|
||||||
[now %logs (tap:log-orm log)]
|
[now %logs (tap:log-orm log.state)]
|
||||||
::
|
::
|
||||||
[%since @ ~]
|
[%since @ ~]
|
||||||
=/ since=@ (rash i.t.t.t.path dem)
|
=/ since=@ (rash i.t.t.t.path dem)
|
||||||
:^ ~ ~ %journal-update
|
:^ ~ ~ %journal-update
|
||||||
!> ^- 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
|
, int, signedInt, bigint
|
||||||
, float32, float64
|
, float32, float64
|
||||||
, cord, tape
|
, 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.
|
{-| 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`.
|
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
|
(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
|
# 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.
|
{-| 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.
|
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.Cmd.Internal
|
||||||
import Ur.Constructor as C
|
import Ur.Constructor as C
|
||||||
import Ur.Deconstructor as D
|
import Ur.Deconstructor as D
|
||||||
|
import Ur.NounDiff exposing (Patch, deconstructPatch)
|
||||||
import Ur.Requests exposing (..)
|
import Ur.Requests exposing (..)
|
||||||
import Ur.Sub
|
import Ur.Sub
|
||||||
import Ur.Sub.Internal
|
import Ur.Sub.Internal
|
||||||
@ -32,6 +33,7 @@ type alias SubDict msg =
|
|||||||
( String, String, List String )
|
( String, String, List String )
|
||||||
{ deconstructor : D.Deconstructor (msg -> msg) msg
|
{ deconstructor : D.Deconstructor (msg -> msg) msg
|
||||||
, number : Int
|
, number : Int
|
||||||
|
, sink : Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
@ -49,6 +51,7 @@ type alias Model app msg =
|
|||||||
, eventId : Int
|
, eventId : Int
|
||||||
, flags : Flags
|
, flags : Flags
|
||||||
, requestsToRetry : List UrbitRequest
|
, requestsToRetry : List UrbitRequest
|
||||||
|
, sinks : Dict Int Noun
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
@ -171,7 +174,6 @@ update inp msg model =
|
|||||||
( appModel, appCmds ) =
|
( appModel, appCmds ) =
|
||||||
inp.update msg_ model.app
|
inp.update msg_ model.app
|
||||||
|
|
||||||
-- { subscriptions, eventId, subscriptionRequests, subscriptionIntMapping } =
|
|
||||||
subsResult =
|
subsResult =
|
||||||
processUrSubs
|
processUrSubs
|
||||||
model.eventId
|
model.eventId
|
||||||
@ -244,14 +246,51 @@ update inp msg model =
|
|||||||
Dict.get messageId model.subscriptionIntMapping
|
Dict.get messageId model.subscriptionIntMapping
|
||||||
|> Maybe.andThen (\key -> Dict.get key model.subscriptions)
|
|> Maybe.andThen (\key -> Dict.get key model.subscriptions)
|
||||||
of
|
of
|
||||||
Just { deconstructor } ->
|
Just { deconstructor, sink } ->
|
||||||
case D.run (D.cell D.ignore (D.cell D.ignore deconstructor)) rest of
|
if sink then
|
||||||
Just subMsg ->
|
case D.run (D.cell D.ignore (D.cell D.ignore deconstructSink)) rest of
|
||||||
( model_, pureCmd (AppMsg subMsg) )
|
Just (Flush noun) ->
|
||||||
|
( { model | sinks = Dict.insert messageId noun model.sinks }
|
||||||
|
, case D.run deconstructor noun of
|
||||||
|
Just subMsg ->
|
||||||
|
pureCmd (AppMsg subMsg)
|
||||||
|
|
||||||
-- Got gargbage
|
-- Got garbage
|
||||||
Nothing ->
|
Nothing ->
|
||||||
( model_, ackCmd )
|
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
|
-- Got a fact for a subscription we do not hold
|
||||||
Nothing ->
|
Nothing ->
|
||||||
@ -280,7 +319,7 @@ update inp msg model =
|
|||||||
|> tag model.eventId
|
|> tag model.eventId
|
||||||
in
|
in
|
||||||
( { model | eventId = eventId }
|
( { model | eventId = eventId }
|
||||||
, send { url = url, requests = reqs, success = OpenConnection, error = NeedsActivation }
|
, send { url = url, requests = reqs, success = OpenConnection, error = Noop }
|
||||||
)
|
)
|
||||||
|
|
||||||
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 -> Ur.Cmd.Cmd msg -> ( EventId, Cmd (Msg msg), List ( EventId, UrbitRequest ) )
|
||||||
processCmd eventId urCmds =
|
processCmd eventId urCmds =
|
||||||
let
|
let
|
||||||
@ -336,10 +388,10 @@ pureCmd msg =
|
|||||||
|
|
||||||
processUrSubs :
|
processUrSubs :
|
||||||
EventId
|
EventId
|
||||||
-> Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId }
|
-> Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId, sink : Bool }
|
||||||
-> Dict ( Ship, Agent, Path ) d
|
-> 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
|
, eventId : EventId
|
||||||
, subscriptionRequests : List ( EventId, UrbitRequest )
|
, subscriptionRequests : List ( EventId, UrbitRequest )
|
||||||
, subscriptionIntMapping : Dict EventId ( Ship, Agent, Path )
|
, subscriptionIntMapping : Dict EventId ( Ship, Agent, Path )
|
||||||
@ -348,7 +400,7 @@ processUrSubs eventId existingSubscriptions urbitSubs_ =
|
|||||||
let
|
let
|
||||||
urbitSubs =
|
urbitSubs =
|
||||||
urbitSubs_
|
urbitSubs_
|
||||||
|> Dict.map (\_ deconstructor -> { deconstructor = deconstructor })
|
|> Dict.map (\_ { deconstructor, sink } -> { deconstructor = deconstructor, sink = sink })
|
||||||
|
|
||||||
( eventId_, newSubscriptionActions ) =
|
( eventId_, newSubscriptionActions ) =
|
||||||
Dict.diff urbitSubs existingSubscriptions
|
Dict.diff urbitSubs existingSubscriptions
|
||||||
@ -371,10 +423,11 @@ processUrSubs eventId existingSubscriptions urbitSubs_ =
|
|||||||
newSubscriptions =
|
newSubscriptions =
|
||||||
Dict.merge
|
Dict.merge
|
||||||
(\_ _ x -> x)
|
(\_ _ x -> x)
|
||||||
(\key number { deconstructor } ->
|
(\key number { deconstructor, sink } ->
|
||||||
Dict.insert key
|
Dict.insert key
|
||||||
{ deconstructor = deconstructor
|
{ deconstructor = deconstructor
|
||||||
, number = number
|
, number = number
|
||||||
|
, sink = sink
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
(\_ _ x -> x)
|
(\_ _ x -> x)
|
||||||
@ -417,6 +470,7 @@ init inp ( app, appCmds ) flags =
|
|||||||
inp.urbitUrl app ++ "/~/channel/" ++ flags.uid
|
inp.urbitUrl app ++ "/~/channel/" ++ flags.uid
|
||||||
in
|
in
|
||||||
( { subscriptions = subsResult.subscriptions
|
( { subscriptions = subsResult.subscriptions
|
||||||
|
, sinks = Dict.empty
|
||||||
, subscriptionIntMapping = subsResult.subscriptionIntMapping
|
, subscriptionIntMapping = subsResult.subscriptionIntMapping
|
||||||
, app = app
|
, app = app
|
||||||
, connected = False
|
, connected = False
|
||||||
@ -439,7 +493,7 @@ init inp ( app, appCmds ) flags =
|
|||||||
|
|
||||||
subscriptions :
|
subscriptions :
|
||||||
{ a | subscriptions : b -> Sub msg, onEventSourceMsg : (JD.Value -> Msg c) -> Sub (Msg msg) }
|
{ 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)
|
-> Sub (Msg msg)
|
||||||
subscriptions inp model =
|
subscriptions inp model =
|
||||||
Sub.batch
|
Sub.batch
|
||||||
@ -450,4 +504,9 @@ subscriptions inp model =
|
|||||||
|
|
||||||
else
|
else
|
||||||
Time.every 1000 (always RetryRequests)
|
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.
|
{-| 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 : String, app : String, path : List String, deconstructor : D.Deconstructor (msg -> msg) msg } -> Sub msg
|
||||||
subscribe { ship, app, path, deconstructor } =
|
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)
|
{-| A subscription that does exactly nothing. (Does not subscribe to anything)
|
||||||
|
@ -10,5 +10,7 @@ type Sub msg
|
|||||||
(Dict
|
(Dict
|
||||||
-- key is (ship, app, path)
|
-- key is (ship, app, path)
|
||||||
( Ship, Agent, 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