Skip to content

Instantly share code, notes, and snippets.

@rupertlssmith
Created January 19, 2018 15:13
Show Gist options
  • Save rupertlssmith/36425c9b0665996deda1abaaa91b953e to your computer and use it in GitHub Desktop.
Save rupertlssmith/36425c9b0665996deda1abaaa91b953e to your computer and use it in GitHub Desktop.
Program Combinator
module ProgramCombinator exposing (..)
import Html exposing (Html)
import Time exposing (Time, every, second)
-- Example
type alias Model =
{ message : String
}
prog1 : HeadlessProgramWithChannel {} String String Never
prog1 =
{ init = ( {}, Cmd.none )
, subscriptions = \_ -> every second (\time -> (toString time))
, update = \time -> \model -> ( model, Cmd.none, [ time ] )
, receive = \_ -> \model -> model
}
prog2 : HtmlProgramWithChannel Model Never Never String
prog2 =
{ init = ( { message = "" }, Cmd.none )
, subscriptions = \_ -> Sub.none
, update = \_ -> \model -> ( model, Cmd.none, [] )
, view = \model -> Html.text <| "message: " ++ model.message
, receive = \message -> \model -> { model | message = message }
}
main =
combineHeadlessAndHtmlWithChannel prog1 prog2 |> Html.program
-- Program convolution
swap : ( a, b ) -> ( b, a )
swap ( a, b ) =
( b, a )
type alias HeadlessProgramWithChannel model msg snd recv =
{ init : ( model, Cmd msg )
, update : msg -> model -> ( model, Cmd msg, List snd )
, subscriptions : model -> Sub msg
, receive : recv -> model -> model
}
type alias HtmlProgramWithChannel model msg snd recv =
{ init : ( model, Cmd msg )
, update : msg -> model -> ( model, Cmd msg, List snd )
, subscriptions : model -> Sub msg
, view : model -> Html msg
, receive : recv -> model -> model
}
type alias HeadlessProgram model msg =
{ init : ( model, Cmd msg )
, update : msg -> model -> ( model, Cmd msg )
, subscriptions : model -> Sub msg
}
type alias HtmlProgram model msg =
{ init : ( model, Cmd msg )
, update : msg -> model -> ( model, Cmd msg )
, subscriptions : model -> Sub msg
, view : model -> Html msg
}
type Msg a b
= AMsg a
| BMsg b
{-| Combines a headless program with a
-}
combineHeadlessAndHtmlWithChannel :
HeadlessProgramWithChannel modela msga send recv
-> HtmlProgramWithChannel modelb msgb recv send
-> HtmlProgram ( modela, modelb ) (Msg msga msgb)
combineHeadlessAndHtmlWithChannel progA progB =
{ init = init progA progB
, update = update progA progB
, subscriptions = subscriptions progA progB
, view = view progB
}
combineHeadlessWithChannel :
HeadlessProgramWithChannel modela msga send recv
-> HeadlessProgramWithChannel modelb msgb recv send
-> HeadlessProgram ( modela, modelb ) (Msg msga msgb)
combineHeadlessWithChannel progA progB =
{ init = init progA progB
, update = update progA progB
, subscriptions = subscriptions progA progB
}
{-| Combines the init fields of two programs.
-}
init :
{ a | init : ( modela, Cmd msga ) }
-> { b | init : ( modelb, Cmd msgb ) }
-> ( ( modela, modelb ), Cmd (Msg msga msgb) )
init progA progB =
let
modelA =
Tuple.first progA.init
modelB =
Tuple.first progB.init
cmdA =
Tuple.second progA.init
cmbB =
Tuple.second progB.init
in
( ( modelA, modelB )
, Cmd.batch
[ Cmd.map AMsg cmdA
, Cmd.map BMsg cmbB
]
)
{-| Combines the update functions of two programs, with receive channels.
-}
update :
{ a | receive : recv -> modela -> modela, update : msga -> modela -> ( modela, Cmd msga, List snd ) }
-> { b | receive : snd -> modelb -> modelb, update : msgb -> modelb -> ( modelb, Cmd msgb, List recv ) }
-> Msg msga msgb
-> ( modela, modelb )
-> ( ( modela, modelb ), Cmd (Msg msga msgb) )
update progA progB msg model =
let
modelA =
Tuple.first model
modelB =
Tuple.second model
updateAndSend progA progB msg modelA modelB tagger =
let
( newModel, cmds, sendItems ) =
progA.update msg modelA
in
( ( newModel
, List.foldl (progB.receive) modelB sendItems
)
, Cmd.map tagger cmds
)
in
case msg of
AMsg amsg ->
updateAndSend progA progB amsg modelA modelB AMsg
BMsg bmsg ->
updateAndSend progB progA bmsg modelB modelA BMsg
|> Tuple.mapFirst swap
{-| Combines the subscriptions of two programs.
-}
subscriptions :
{ a | subscriptions : modela -> Sub msga }
-> { b | subscriptions : modelb -> Sub msgb }
-> ( modela, modelb )
-> Sub (Msg msga msgb)
subscriptions progA progB model =
let
modelA =
Tuple.first model
modelB =
Tuple.second model
in
Sub.batch
[ progA.subscriptions modelA |> Sub.map AMsg
, progB.subscriptions modelB |> Sub.map BMsg
]
{-| Lifts the view of one program as the view of a combined program.
-}
view :
{ b | view : modelb -> Html msgb }
-> ( modela, modelb )
-> Html (Msg msga msgb)
view progB model =
let
modelB =
Tuple.second model
in
progB.view modelB |> Html.map BMsg
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment