From 7f496c3605f3448710d29be554f240e3c1802cb7 Mon Sep 17 00:00:00 2001 From: iko Date: Sun, 2 Jul 2023 18:22:13 +0300 Subject: [PATCH] %sink --- .gitignore | 1 + dev/{elm-live.sh => sink-elm-live.sh} | 2 +- dev/vanilla-elm-live.sh | 7 + example/script.js | 17 +- example/src/Sink.elm | 204 ++++++++++++++++ example/src/{Main.elm => Vanilla.elm} | 18 +- example/{journal => urbit}/app/journal.hoon | 48 ++-- example/{journal => urbit}/desk.bill | 0 example/{journal => urbit}/desk.docket-0 | 0 .../{journal => urbit}/gen/journal/add.hoon | 0 example/{journal => urbit}/lib/agentio.hoon | 0 example/{journal => urbit}/lib/dbug.hoon | 0 .../{journal => urbit}/lib/default-agent.hoon | 0 example/{journal => urbit}/lib/docket.hoon | 0 example/{journal => urbit}/lib/journal.hoon | 0 example/urbit/lib/noun-diff.hoon | 227 ++++++++++++++++++ example/urbit/lib/sink.hoon | 27 +++ example/{journal => urbit}/lib/skeleton.hoon | 0 example/{journal => urbit}/mar/bill.hoon | 0 example/{journal => urbit}/mar/docket-0.hoon | 0 example/{journal => urbit}/mar/hoon.hoon | 0 example/{journal => urbit}/mar/jam.hoon | 0 .../mar/journal/action.hoon | 0 .../mar/journal/update.hoon | 0 example/{journal => urbit}/mar/json.hoon | 0 example/{journal => urbit}/mar/kelvin.hoon | 0 example/{journal => urbit}/mar/mime.hoon | 0 example/{journal => urbit}/mar/noun.hoon | 0 example/{journal => urbit}/mar/txt-diff.hoon | 0 example/{journal => urbit}/mar/txt.hoon | 0 example/{journal => urbit}/sur/docket.hoon | 0 example/{journal => urbit}/sur/journal.hoon | 0 example/{journal => urbit}/sys.kelvin | 0 src/Ur/Deconstructor.elm | 19 +- src/Ur/NounDiff.elm | 155 ++++++++++++ src/Ur/Run.elm | 89 +++++-- src/Ur/Sub.elm | 22 +- src/Ur/Sub/Internal.elm | 4 +- 38 files changed, 790 insertions(+), 50 deletions(-) rename dev/{elm-live.sh => sink-elm-live.sh} (60%) create mode 100755 dev/vanilla-elm-live.sh create mode 100644 example/src/Sink.elm rename example/src/{Main.elm => Vanilla.elm} (95%) rename example/{journal => urbit}/app/journal.hoon (66%) rename example/{journal => urbit}/desk.bill (100%) rename example/{journal => urbit}/desk.docket-0 (100%) rename example/{journal => urbit}/gen/journal/add.hoon (100%) rename example/{journal => urbit}/lib/agentio.hoon (100%) rename example/{journal => urbit}/lib/dbug.hoon (100%) rename example/{journal => urbit}/lib/default-agent.hoon (100%) rename example/{journal => urbit}/lib/docket.hoon (100%) rename example/{journal => urbit}/lib/journal.hoon (100%) create mode 100644 example/urbit/lib/noun-diff.hoon create mode 100644 example/urbit/lib/sink.hoon rename example/{journal => urbit}/lib/skeleton.hoon (100%) rename example/{journal => urbit}/mar/bill.hoon (100%) rename example/{journal => urbit}/mar/docket-0.hoon (100%) rename example/{journal => urbit}/mar/hoon.hoon (100%) rename example/{journal => urbit}/mar/jam.hoon (100%) rename example/{journal => urbit}/mar/journal/action.hoon (100%) rename example/{journal => urbit}/mar/journal/update.hoon (100%) rename example/{journal => urbit}/mar/json.hoon (100%) rename example/{journal => urbit}/mar/kelvin.hoon (100%) rename example/{journal => urbit}/mar/mime.hoon (100%) rename example/{journal => urbit}/mar/noun.hoon (100%) rename example/{journal => urbit}/mar/txt-diff.hoon (100%) rename example/{journal => urbit}/mar/txt.hoon (100%) rename example/{journal => urbit}/sur/docket.hoon (100%) rename example/{journal => urbit}/sur/journal.hoon (100%) rename example/{journal => urbit}/sys.kelvin (100%) create mode 100644 src/Ur/NounDiff.elm diff --git a/.gitignore b/.gitignore index 3bd52a1..6d7cbea 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ elm-stuff elm.js +zod diff --git a/dev/elm-live.sh b/dev/sink-elm-live.sh similarity index 60% rename from dev/elm-live.sh rename to dev/sink-elm-live.sh index a6b76fb..325c0cb 100755 --- a/dev/elm-live.sh +++ b/dev/sink-elm-live.sh @@ -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 "$@" diff --git a/dev/vanilla-elm-live.sh b/dev/vanilla-elm-live.sh new file mode 100755 index 0000000..7349bba --- /dev/null +++ b/dev/vanilla-elm-live.sh @@ -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 "$@" diff --git a/example/script.js b/example/script.js index c226184..da70a0b 100644 --- a/example/script.js +++ b/example/script.js @@ -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, { diff --git a/example/src/Sink.elm b/example/src/Sink.elm new file mode 100644 index 0000000..313280a --- /dev/null +++ b/example/src/Sink.elm @@ -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 diff --git a/example/src/Main.elm b/example/src/Vanilla.elm similarity index 95% rename from example/src/Main.elm rename to example/src/Vanilla.elm index 4763a29..c57ed74 100644 --- a/example/src/Main.elm +++ b/example/src/Vanilla.elm @@ -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 } diff --git a/example/journal/app/journal.hoon b/example/urbit/app/journal.hoon similarity index 66% rename from example/journal/app/journal.hoon rename to example/urbit/app/journal.hoon index 0a7005a..56c912a 100644 --- a/example/journal/app/journal.hoon +++ b/example/urbit/app/journal.hoon @@ -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 ~))] == == :: diff --git a/example/journal/desk.bill b/example/urbit/desk.bill similarity index 100% rename from example/journal/desk.bill rename to example/urbit/desk.bill diff --git a/example/journal/desk.docket-0 b/example/urbit/desk.docket-0 similarity index 100% rename from example/journal/desk.docket-0 rename to example/urbit/desk.docket-0 diff --git a/example/journal/gen/journal/add.hoon b/example/urbit/gen/journal/add.hoon similarity index 100% rename from example/journal/gen/journal/add.hoon rename to example/urbit/gen/journal/add.hoon diff --git a/example/journal/lib/agentio.hoon b/example/urbit/lib/agentio.hoon similarity index 100% rename from example/journal/lib/agentio.hoon rename to example/urbit/lib/agentio.hoon diff --git a/example/journal/lib/dbug.hoon b/example/urbit/lib/dbug.hoon similarity index 100% rename from example/journal/lib/dbug.hoon rename to example/urbit/lib/dbug.hoon diff --git a/example/journal/lib/default-agent.hoon b/example/urbit/lib/default-agent.hoon similarity index 100% rename from example/journal/lib/default-agent.hoon rename to example/urbit/lib/default-agent.hoon diff --git a/example/journal/lib/docket.hoon b/example/urbit/lib/docket.hoon similarity index 100% rename from example/journal/lib/docket.hoon rename to example/urbit/lib/docket.hoon diff --git a/example/journal/lib/journal.hoon b/example/urbit/lib/journal.hoon similarity index 100% rename from example/journal/lib/journal.hoon rename to example/urbit/lib/journal.hoon diff --git a/example/urbit/lib/noun-diff.hoon b/example/urbit/lib/noun-diff.hoon new file mode 100644 index 0000000..3ce82ac --- /dev/null +++ b/example/urbit/lib/noun-diff.hoon @@ -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 + == + -- +-- diff --git a/example/urbit/lib/sink.hoon b/example/urbit/lib/sink.hoon new file mode 100644 index 0000000..14b0b7c --- /dev/null +++ b/example/urbit/lib/sink.hoon @@ -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)]))] + -- +-- \ No newline at end of file diff --git a/example/journal/lib/skeleton.hoon b/example/urbit/lib/skeleton.hoon similarity index 100% rename from example/journal/lib/skeleton.hoon rename to example/urbit/lib/skeleton.hoon diff --git a/example/journal/mar/bill.hoon b/example/urbit/mar/bill.hoon similarity index 100% rename from example/journal/mar/bill.hoon rename to example/urbit/mar/bill.hoon diff --git a/example/journal/mar/docket-0.hoon b/example/urbit/mar/docket-0.hoon similarity index 100% rename from example/journal/mar/docket-0.hoon rename to example/urbit/mar/docket-0.hoon diff --git a/example/journal/mar/hoon.hoon b/example/urbit/mar/hoon.hoon similarity index 100% rename from example/journal/mar/hoon.hoon rename to example/urbit/mar/hoon.hoon diff --git a/example/journal/mar/jam.hoon b/example/urbit/mar/jam.hoon similarity index 100% rename from example/journal/mar/jam.hoon rename to example/urbit/mar/jam.hoon diff --git a/example/journal/mar/journal/action.hoon b/example/urbit/mar/journal/action.hoon similarity index 100% rename from example/journal/mar/journal/action.hoon rename to example/urbit/mar/journal/action.hoon diff --git a/example/journal/mar/journal/update.hoon b/example/urbit/mar/journal/update.hoon similarity index 100% rename from example/journal/mar/journal/update.hoon rename to example/urbit/mar/journal/update.hoon diff --git a/example/journal/mar/json.hoon b/example/urbit/mar/json.hoon similarity index 100% rename from example/journal/mar/json.hoon rename to example/urbit/mar/json.hoon diff --git a/example/journal/mar/kelvin.hoon b/example/urbit/mar/kelvin.hoon similarity index 100% rename from example/journal/mar/kelvin.hoon rename to example/urbit/mar/kelvin.hoon diff --git a/example/journal/mar/mime.hoon b/example/urbit/mar/mime.hoon similarity index 100% rename from example/journal/mar/mime.hoon rename to example/urbit/mar/mime.hoon diff --git a/example/journal/mar/noun.hoon b/example/urbit/mar/noun.hoon similarity index 100% rename from example/journal/mar/noun.hoon rename to example/urbit/mar/noun.hoon diff --git a/example/journal/mar/txt-diff.hoon b/example/urbit/mar/txt-diff.hoon similarity index 100% rename from example/journal/mar/txt-diff.hoon rename to example/urbit/mar/txt-diff.hoon diff --git a/example/journal/mar/txt.hoon b/example/urbit/mar/txt.hoon similarity index 100% rename from example/journal/mar/txt.hoon rename to example/urbit/mar/txt.hoon diff --git a/example/journal/sur/docket.hoon b/example/urbit/sur/docket.hoon similarity index 100% rename from example/journal/sur/docket.hoon rename to example/urbit/sur/docket.hoon diff --git a/example/journal/sur/journal.hoon b/example/urbit/sur/journal.hoon similarity index 100% rename from example/journal/sur/journal.hoon rename to example/urbit/sur/journal.hoon diff --git a/example/journal/sys.kelvin b/example/urbit/sys.kelvin similarity index 100% rename from example/journal/sys.kelvin rename to example/urbit/sys.kelvin diff --git a/src/Ur/Deconstructor.elm b/src/Ur/Deconstructor.elm index 8b7a9a2..1216400 100644 --- a/src/Ur/Deconstructor.elm +++ b/src/Ur/Deconstructor.elm @@ -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. diff --git a/src/Ur/NounDiff.elm b/src/Ur/NounDiff.elm new file mode 100644 index 0000000..f985e9c --- /dev/null +++ b/src/Ur/NounDiff.elm @@ -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 + ] diff --git a/src/Ur/Run.elm b/src/Ur/Run.elm index b65162f..e2b5362 100644 --- a/src/Ur/Run.elm +++ b/src/Ur/Run.elm @@ -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 ] diff --git a/src/Ur/Sub.elm b/src/Ur/Sub.elm index 0ddb9ce..4f1007a 100644 --- a/src/Ur/Sub.elm +++ b/src/Ur/Sub.elm @@ -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) diff --git a/src/Ur/Sub/Internal.elm b/src/Ur/Sub/Internal.elm index dc7f761..ac2c929 100644 --- a/src/Ur/Sub/Internal.elm +++ b/src/Ur/Sub/Internal.elm @@ -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 + } )